Как мне узнать, какая часть моего кода не меняет раздел копирования во время цикла?

Question

Код выполняется до завершения, но я ничего не сбрасываю до следующего цикла, и созданные таблицы все такие же, как на первом листе! Куда я иду не так?

Возможно, что-то делать с сводным кешем?

Вот документ, с которым я работаю.

Answer 1

Вы должны были изменить переменную WS_Count на I в этой строке:

Оригинал:

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

Для:

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

Пытался очистить код столько, сколько мне позволяло:

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 wbm 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

    Dim wsCounter As Integer

    On Error GoTo errHandler

    ' Reference the current workbook
    Set wbA = ThisWorkbook

    ' Define current separator
    mySep = "|"

    'join operator for Excel formulas
    myJoin = "&"

    ' Set first columns that wont be unpivoted
    NumCols = 7

    ' Loop through the current workbook sheets
    For Each wsA In wbA.Worksheets

        ' Set a worksheet counter
        wsCounter = wsCounter + 1

        ' Convert current region to table / listobject
        wsA.ListObjects.Add(SourceType:=xlSrcRange, _
        Source:=wsA.Cells.CurrentRegion, _
        xlListObjectHasHeaders:=xlYes _
        ).Name = "myTable" & wsCounter

        ' Copy worksheet to new file and set a reference
        wsA.Copy
        Set wbNew = ActiveWorkbook
        Set wsNew = wbNew.Sheets(1)

        ' Reference the table / listobject in the new file
        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


        ' Note: I couldn't understand what you wanted to do with this lines. Replace the current data?
        wsNewData.Copy after:=wbA.Worksheets(wbA.Worksheets.Count)
        wbNew.Close savechanges:=False

    Next wsA

    msgEnd = "Data is unpivoted in new worksheets"


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

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

End Sub

Код обновлен: скопируйте листы обратно в текущий файл

Отметьте ответ, если это поможет.