Как я могу изменить этот работающий макрос отмены вращения, чтобы пройтись по всем листам в книге и добавить? - PullRequest
Новая
       15

Как я могу изменить этот работающий макрос отмены вращения, чтобы пройтись по всем листам в книге и добавить?

0 голосов
/ 12 мая 2019

Я обнаружил отличный код, который успешно удаляет существующую таблицу из таблицы.У меня возникли проблемы с его изменением в соответствии с моими потребностями:

  1. Как заставить его перестать запрашивать ответы на сообщения MSG, но установить значения по умолчанию?

  2. как мне заставить это делать это в цикле для всех листов рабочей книги

Я не очень хорош в vba, и мои модификации могут работать индивидуально, но не вместе.

Это код, который я использую: 

Option Explicit

Sub UnpivotData()
'downloaded from contextures.com
'code to unpivot named Excel table
'uses first table on the sheet,
'if more than one table
Dim myList As ListObject
Dim NumCols As Long
Dim PT01 As PivotTable
Dim wbA As Workbook
Dim wbNew As Workbook
Dim wsA As Worksheet
Dim wsNew As Worksheet
Dim wsPT As Worksheet
Dim wsNewData As Worksheet
Dim myData As Range
Dim mySep As String
Dim myJoin As String
Dim ColStart As Long
Dim ColEnd As Long
Dim ColCount As Long
Dim RowStart As Long
Dim RowEnd As Long
Dim RowCount As Long
Dim DataStart As Range
Dim DataEnd As Range
Dim iCol As Long
Dim myFormula As String
Dim msgSep As String
Dim msgLabels As String
Dim msgEnd As String

On Error GoTo errHandler

Set wsA = ActiveSheet
Set wbA = ActiveWorkbook
msgSep = "The macro will temporarily combine the labels,"
msgSep = msgSep & vbCrLf
msgSep = msgSep & "and then split them."
msgSep = msgSep & vbCrLf
msgSep = msgSep & vbCrLf
msgSep = msgSep & "Please enter a single character"
msgSep = msgSep & vbCrLf
msgSep = msgSep & "that's not in your labels,"
msgSep = msgSep & vbCrLf
msgSep = msgSep & "such as | (default in box below)"

mySep = InputBox(msgSep, "Split Character", "|")

'join operator for Excel formulas
myJoin = "&"

Select Case Len(mySep)
  Case 0
    MsgBox "No split character was entered -- cancelling macro"
    GoTo exitHandler
  Case Is > 1
    MsgBox "Only one character is allowed for splitting -- cancelling macro"
    GoTo exitHandler
  Case Else
    'do nothing
End Select

msgLabels = "How many columns, at the left side"
msgLabels = msgLabels & vbCrLf
msgLabels = msgLabels & "of the table, contain labels?"
msgLabels = msgLabels & vbCrLf
msgLabels = msgLabels & vbCrLf
msgLabels = msgLabels & "Remaining columns, at the right,"
msgLabels = msgLabels & vbCrLf
msgLabels = msgLabels & "will be unpivoted"

On Error Resume Next
NumCols = 0
NumCols = CLng(InputBox(msgLabels, "Label Columns", 1))
On Error GoTo errHandler

Select Case NumCols
  Case 0
    MsgBox "No columns entered -- cancelling macro"
    GoTo exitHandler
  Case Else
    'do nothing
End Select

Application.ScreenUpdating = False
Application.EnableEvents = False

wsA.Copy
Set wbNew = ActiveWorkbook
Set wsNew = ActiveSheet

Set myList = wsNew.ListObjects(1)

With myList
  ColStart = .HeaderRowRange.Columns(1).Column
  RowStart = .HeaderRowRange.Columns(1).Row
  RowCount = .DataBodyRange.Rows.Count
  RowEnd = .DataBodyRange.Rows(RowCount).Row
  'insert column for the combined labels
  wsNew.Columns(NumCols + ColStart).Insert Shift:=xlToRight
  ColCount = .DataBodyRange.Columns.Count
  ColEnd = .DataBodyRange.Columns(ColCount).Column
End With

'build formula to combine labels
myFormula = "=("
For iCol = 1 To NumCols
  myFormula = myFormula & "[@" _
    & myList.HeaderRowRange(1, iCol).Value _
    & "]" & myJoin & Chr(34) _
    & mySep & Chr(34) & myJoin
Next iCol

myFormula = Left(myFormula, Len(myFormula) - 5)
myFormula = myFormula & ")"

With myList
  .DataBodyRange.Cells(1, NumCols + 1).Formula = myFormula
  .DataBodyRange.Columns(NumCols + 1).Value _
    = .DataBodyRange.Columns(NumCols + 1).Value
  Set DataStart = .HeaderRowRange(1, NumCols + 1)
End With

Set DataEnd = wsNew.Cells(RowEnd, ColEnd)
Set myData = wsNew.Range(DataStart, DataEnd)

'create multiple consolidation pivot table
wbNew.PivotCaches.Create(SourceType:=xlConsolidation, _
    SourceData:=wsA.Name & "!" _
      & myData.Address(, , xlR1C1)).CreatePivotTable _
    TableDestination:="", _
    TableName:="PT1"
Set wsPT = ActiveSheet
Set PT01 = wsPT.PivotTables(1)

With PT01
  .ColumnFields(1).Orientation = xlHidden
  .RowFields(1).Orientation = xlHidden
End With

'move combined labels to right, and split
'then move back to left side of table
wsPT.Range("A2").ShowDetail = True
Set wsNewData = ActiveSheet
With wsNewData
  .Columns("B:C").Cut
  .Columns("A:B").Insert Shift:=xlToRight
  .Columns("C:C").TextToColumns _
      Destination:=.Range("C1"), _
      DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, _
      ConsecutiveDelimiter:=False, _
      Tab:=False, _
      Semicolon:=False, _
      Comma:=False, _
      Space:=False, _
      Other:=True, _
      OtherChar:=mySep
  .Range(.Cells(1, 3), .Cells(1, NumCols + 2)) _
      .EntireColumn.Cut
  .Range(.Cells(1, 1), .Cells(1, NumCols)) _
      .EntireColumn.Insert Shift:=xlToRight
End With

With myList.HeaderRowRange
  .Resize(, NumCols).Copy _
    Destination:=wsNewData.Cells(1, 1)
End With

On Error Resume Next
wsNewData.Cells(1, NumCols + 1).Select

msgEnd = "Data is unpivoted in new workbook" _
  & vbCrLf _
  & "Change headings and copy to original workbook"

exitHandler:
  Application.ScreenUpdating = True
  MsgBox msgEnd
  Application.EnableEvents = True
  Exit Sub

errHandler:
  msgEnd = "Could not unpivot the data"
  Resume exitHandler

End Sub

кредит: http://www.contextures.com/excelunpivotmacro.html

Мой набор данных выглядит так:

https://drive.google.com/file/d/1hfah_BHCkdisxpAQ7krrsE58-NWdu2h2/view?usp=sharing

обновление: хорошо, что получаются созданные таблицы: 

Sub ConvertRangeToTable()

ActiveSheet.ListObjects.Add(SourceType:=xlSrcRange, _
    Source:=Selection.CurrentRegion, _
    xlListObjectHasHeaders:=xlYes _
    ).Name = "myTable"

End Sub

Необходимо выяснить, как перебирать таблицы

...