Альтернативы двойному циклу

Question

Я использую макрос для реорганизации 4600 строк данных в более эффективный макет. В настоящее время у меня есть макрос, но он пропускает данные или помещает данные в неправильном месте.

Из старых данных столбец A - это номер уведомления, столбец FO - номер листа, а GB - номер зоны. В то время как столбец C - это данные, которые нужно ввести. Так что в настоящее время (как показано на фотографии, данные очень неорганизованы и нечитаемы.

В выводимом листе номер уведомления помещается в строку 1 в столбцах F на палатах (без дубликатов). В столбцах B и C - это зона и номер листа соответственно (без дубликатов). Затем, используя старые данные, выведите значения столбца C в правильном столбце (в зависимости от номера уведомления) и в правильной строке (в зависимости от зоны и номера листа).

Я достиг половины этого, но не все значения введены неправильно.

В настоящее время я использую range.find, чтобы увидеть, существует ли номер зоны, и не добавляет ли она зону значение и номер листа в последнюю использованную строку. Однако, если номер зоны найден, но соответствующий номер листа отличается, добавьте эти значения, а затем также добавьте значения из столбца C. Однако, если заполнена правильная ячейка найти следующую доступную ячейку в столбце, который является пустым и введите значение.

Но я не могу найти лучший способ проверить т Эти значения, чем использование range.find, но я чувствую, что отсутствуют значения и неправильно сравниваются оба значения.

Sub GenerateTable()

Application.ScreenUpdating = False

Dim RawDataWsNotificationRng, ModifiedDataWsNotificationRng As Variant
Dim cell As Range
Dim RawDataWsNotificationlrow, ModifiedDataWsNotificationlcolnum, ModifiedDataWsZoneLrow As Long
Dim ModifiedDataWsNotificationlcol As String
Dim serverfilename, DataSheetName, Newsheetname As String
Dim wkbk1, wkbk2 As Workbook
Dim RawDataWs, ModifiedDataWs As Worksheet
Dim FindNotificationNumber As Variant

serverfilename = InputBox("Please input name of dummy workbook (file must be open, include .xlsx")
If serverfilename = "" Then Exit Sub

Set wb1 = ThisWorkbook
Set wb2 = Workbooks(serverfilename)

DataSheetName = InputBox("Please enter name of sheet where data is stored")
If DataSheetName = "" Then Exit Sub

Set RawDataWs = wb2.Sheets(DataSheetName)
Set ModifiedDataWs = Sheets.Add(After:=Sheets(Sheets.Count))

Newsheetname = InputBox("Please enter name of new sheet")
ModifiedDataWs.Name = Newsheetname

RawDataWsNotificationlrow = RawDataWs.Range("A" & Rows.Count).End(xlUp).Row
ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row

ModifiedDataWsNotificationlcolnum = ModifiedDataWs.Cells(1, Columns.Count).End(xlToLeft).Column + 1
ModifiedDataWsNotificationlcol = Split(Cells(1, ModifiedDataWsNotificationlcolnum).Address, "$")(1)

Set RawDataWsNotificationRng = RawDataWs.Range("A2:A" & RawDataWsNotificationlrow)
Set ModifiedDataWsNotificationRng = ModifiedDataWs.Range("F1:" & ModifiedDataWsNotificationlcol & "1")

'------------------------------------TableFeatures---------------------------------------------

With ModifiedDataWs
    .Cells(1, "A").Value = "Feature Code"
    .Cells(1, "B").Value = "Zone"
    .Cells(1, "C").Value = "Sheet"
    .Cells(1, "D").Value = "Feature Description"
    .Cells(1, "E").Value = "'-TEN OGV KH73126 tolerance"
    .Cells(1, "F").Value = "'-TEN OGV KH73126 tolerance"
    .Cells(2, "E").Value = "Nominal"
    .Cells(2, "F").Value = "Tolerance"

'------------------------------------NotificationColumns---------------------------------------------

    For Each cell In RawDataWsNotificationRng

        Set ModifiedDataWsNotificationRng = .Range("G1:" & ModifiedDataWsNotificationlcol & "1")
        Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(what:=RawDataWs.Cells(cell.Row, "A"), lookat:=xlWhole)

        If FindNotificationNumber Is Nothing Then
            ModifiedDataWsNotificationlcolnum = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
            ModifiedDataWsNotificationlcol = Split(Cells(1, ModifiedDataWsNotificationlcolnum).Address, "$")(1)
            Cells(1, ModifiedDataWsNotificationlcol).Value = cell.Value
        End If

    Next cell

'------------------------------------ZoneandSheetValues---------------------------------------------

Dim RawDataWsZoneRng As Variant: Set RawDataWsZoneRng = RawDataWs.Range("GB2:GB" & RawDataWsNotificationlrow)
Dim ModifiedDataWsZoneRng As Variant: Set ModifiedDataWsZoneRng = ModifiedDataWs.Range("B:B")
Dim ModifiedDataWssheetRng As Variant: Set ModifiedDataWssheetRng = ModifiedDataWs.Range("C:C")
Dim RawDataWsExtentRng As Variant: Set RawDataWsExtentRng = RawDataWs.Range("C2:C" & RawDataWsNotificationlrow)
Dim cel As Range
Dim ColumnLetterLRow, LR As Long, ColumnLetter As String, FindSheetinModifiedWs As Variant

ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row

    For Each cell In RawDataWsZoneRng
    Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(what:=RawDataWs.Cells(cell.Row, "A"), lookat:=xlWhole)
    Set FindZoneInModifiedWs = ModifiedDataWsZoneRng.Find(what:=cell.Value, lookat:=xlWhole)
    Set FindSheetinModifiedWs = ModifiedDataWssheetRng.Find(what:=RawDataWs.Cells(cell.Row, "FO"), lookat:=xlWhole)
        If RawDataWs.Cells(cell.Row, "H").Value = "CONACC" Then
            If FindZoneInModifiedWs Is Nothing Then
                LR = .Range("A:" & ModifiedDataWsNotificationlcol).SpecialCells(xlCellTypeLastCell).Row + 1
                    .Cells(LR, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
                    .Cells(LR, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
                    .Cells(LR, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
            Else
                If Not FindZoneInModifiedWs Is Nothing And FindSheetinModifiedWs Is Nothing Then
                        LR = .Range("A:" & ModifiedDataWsNotificationlcol).SpecialCells(xlCellTypeLastCell).Row + 1
                            .Cells(LR, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
                            .Cells(LR, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
                            .Cells(LR, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
            Else
                    If cell.Value <> vbNullString Then
                    ColumnLetter = Split(Cells(1, FindNotificationNumber.Column).Address, "$")(1)
                         If (.Cells(FindZoneInModifiedWs.Row, ColumnLetter) = vbNullString) Then
                            ColumnLetterLRow = FindZoneInModifiedWs.Row
                        Else
                            Set ColumnLetterRow = .Range(ColumnLetter & FindZoneInModifiedWs.Row & ":" & ColumnLetter & "30000").Find(what:="", lookat:=xlWhole)
                                ColumnLetterLRow = ColumnLetterRow.Row
                        End If
                    .Cells(ColumnLetterLRow, FindNotificationNumber.Column).Value = RawDataWs.Cells(cell.Row, "C").Value
                    .Cells(ColumnLetterLRow, "B").Value = RawDataWs.Cells(cell.Row, "GB").Value
                    .Cells(ColumnLetterLRow, "C").Value = RawDataWs.Cells(cell.Row, "FO").Value
                    End If
                End If
            End If
        End If
    ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
    Next cell

'--------------------------Loop through zones and find input all values for zones-----------------

ModifiedDataWsZoneLrow = ModifiedDataWs.Range("B" & Rows.Count).End(xlUp).Row
Set ModifiedDataWsZoneRng = ModifiedDataWs.Range("B3:B" & ModifiedDataWsZoneLrow)
Dim nextrow As Long

For Each cell In ModifiedDataWsZoneRng
    For Each cel In RawDataWsZoneRng
        If cel.Value = cell.Value Then
            Set FindNotificationNumber = ModifiedDataWsNotificationRng.Find(What:=RawDataWs.Cells(cel.Row, "A"), lookat:=xlWhole)
            Set FindZoneInModifiedWs = ModifiedDataWsZoneRng.Find(What:=cell.Value, lookat:=xlWhole)
            If IsEmpty(.Cells(FindZoneInModifiedWs.Row, FindNotificationNumber.Column).Value) = True Then
                .Cells(FindZoneInModifiedWs.Row, FindNotificationNumber.Column).Value = RawDataWs.Cells(cel.Row, "C").Value
                .Cells(FindZoneInModifiedWs.Row, "B").Value = RawDataWs.Cells(cel.Row, "GB").Value
                .Cells(FindZoneInModifiedWs.Row, "C").Value = RawDataWs.Cells(cel.Row, "FO").Value
            Else
            End If
        End If
    Next cel
Next cell

любые идеи будут с благодарностью! извините, я новичок в VBA!

Старый лист данных

Новый лист

Ссылка на книгу

Ссылка на книгу

Answer 1

Ну, это сложнее, чем я думал, но здесь:

'type to manage data we use from each row
Type dataRow
    notif As Variant
    variable As Variant
    sht As Variant
    zone As Variant
End Type

Sub DoPivot()
    Const SEP As String = "<>"
    Dim rngData As Range, data, r As Long
    Dim colDict As Object, rowDict As Object, comboDict As Object
    Dim rd As dataRow, rngOutput As Range, col As Long, rw As Long, k
    Dim k2, arr, dictCounts As Object
    Dim wsOut As Worksheet, num As Long

    Set colDict = CreateObject("scripting.dictionary")
    Set rowDict = CreateObject("scripting.dictionary")
    Set comboDict = CreateObject("scripting.dictionary")
    Set dictCounts = CreateObject("scripting.dictionary")

    data = Sheet9.Range("A2:D4788").Value 'source data

    Set rngOutput = Sheet9.Range("H1")    'top-left cell for output
    Set wsOut = rngOutput.Parent

    rngOutput.Resize(5000, 5000).ClearContents

    rngOutput.Resize(1, 2).Value = Array("Sheet", "Zone")

    col = rngOutput.Column + 2 'start for notification# headers
    rw = rngOutput.row + 1

    'first pass - assess data variables
    For r = 1 To UBound(data, 1)
        rd = rowData(data, r)
        k = Join(Array(rd.sht, rd.zone, rd.notif), SEP) 'tracking how many unique combinations of these
        comboDict(k) = comboDict(k) + 1 'increment count
        'manage column header positions for unique notification numbers
        If Not colDict.exists(rd.notif) Then
            colDict.Add rd.notif, col 'store the column
            rngOutput.EntireRow.Cells(1, col).Value = rd.notif 'add the header
            col = col + 1
        End If
    Next r

    'figure out # of rows for each sheet-Zone pair
    For Each k In comboDict.keys
        arr = Split(k, SEP)
        k2 = Join(Array(arr(0), arr(1)), SEP) 'sheet<>zone
        'is this more rows than any previous same k2 value?
        dictCounts(k2) = Application.Max(dictCounts(k2), comboDict(k))
    Next k

    'create the row headers
    For Each k In dictCounts.keys
        num = dictCounts(k)
        rowDict(k) = rw         'record start row for each sheet<>zone combo
        wsOut.Cells(rw, rngOutput.Column).Resize(num, 2).Value = Split(k, SEP)
        dictCounts(k) = 0 'reset so we can track while adding data
        rowDict(k) = rw
        rw = rw + num
    Next k

    'last pass - populate the data based on the dictionaries
    For r = 1 To UBound(data, 1)
        rd = rowData(data, r)
        k = Join(Array(rd.sht, rd.zone, rd.notif), SEP) '3-field combo
        k2 = Join(Array(rd.sht, rd.zone), SEP)          'row key

        wsOut.Cells(rowDict(k2) + (dictCounts(k)), _
                    colDict(rd.notif)).Value = rd.variable

        dictCounts(k) = dictCounts(k) + 1               'increment this unique combo

    Next r

End Sub

'populate a Type instance for a given row
Function rowData(data, r As Long) As dataRow
    Dim rv As dataRow
    rv.notif = IfEmpty(data(r, 1))
    rv.variable = IfEmpty(data(r, 2))
    rv.sht = IfEmpty(data(r, 3))
    rv.zone = IfEmpty(data(r, 4))
    rowData = rv
End Function

'substitute EMPTY for zero-length value
Function IfEmpty(v)
    IfEmpty = IIf(Len(v) = 0, "EMPTY", v)
End Function

РЕДАКТИРОВАТЬ : если вы хотите отфильтровать определенные строки, вам нужно изменить циклы который перебирает data

For r = 1 To UBound(data, 1)
    If data(r, colHere) <> "X" Then '<<  add your filter here
        rd = rowData(data, r) 

        'rest of code as before...

    End If
Next r