Excel VBA - 将基于两个参数的数据复制到另一个工作表中

Question

我正在尝试将包含原始数据（超过 30 列和 300000 行）的 sheet 中的数据复制到其他 sheet 中，将它们拆分成有组织的形式。

在数据中 sheet 我在 A 列中有重复的 ID，在 B 列中有唯一的案例编号，在 J 列中有案例日期（多个案例编号具有相同的日期）。

我的目标是将案例编号复制到工作 sheet 中，这些工作 sheet 以 A 栏中的 ID 命名。在目标 sheet 中，我在 A 栏中有单个日期（例如从 3/ A1 中的 01/2021 到 A31 中的 2021 年 3 月 31 日）。案例编号需要调换，以便它们出现在彼此相邻的列中，但它们具有相同的日期。

我不能在代码中使用 ID 的名称，因为它每个月都在变化，所以我想代码需要用作某种比较工具。

Answer 1

这应该是关闭的：如果工作表尚不存在，它将添加工作表。

Sub Copy_to_ID_sheet()

    Dim impdate As Date, startDate As Date, daysToFillDown As Long
    Dim finalrow As Long
    Dim i As Long, numSheets As Long
    Dim shipment As String, m
    Dim ID As String, wsDane As Worksheet, dict As Object, ws As Worksheet
    
    startDate  = DateSerial(2021, 3, 1) 'adjust as needed
    daysToFillDown  = 31                '...and here

    Set wsDane = ThisWorkbook.Sheets("Dane")
    numSheets = ThisWorkbook.Worksheets.Count
    
    Set dict = CreateObject("scripting.dictionary")
    
    For i = 2 To wsDane.Cells(Rows.Count, "A").End(xlUp).Row
    
        impdate = wsDane.Cells(i, 10).Value
        shipment = wsDane.Cells(i, 2).Value
        ID = Sheets("Dane").Cells(i, 1).Value
        
        'already seen this ID and have a matching sheet?
        If Not dict.exists(ID) Then
            Set ws = Nothing
            On Error Resume Next
            Set ws = ThisWorkbook.Sheets(ID) 'does the sheet already exist?
            On Error GoTo 0
            If ws Is Nothing Then
                'no existing sheet, so add a new one
                Set ws = ThisWorkbook.Worksheets.Add( _
                         after:=ThisWorkbook.Worksheets(numSheets))
                numSheets = numSheets + 1
                ws.Name = ID
                'add dates to the new sheet
                With ws.Range("A1")
                    .NumberFormat = "mm/dd/yyyy" 'or whatever
                    .Value = startDate
                    .AutoFill Destination:=.Resize(daysToFillDown, 1)
                End With
            End If
            Set dict(ID) = ws 'save in dictionary
        Else
            Set ws = dict(ID) 'get the existing sheet
        End If
    
        'match the date to the destination sheet
        m = Application.Match(CLng(impdate), ws.Range("A1:A40"), 0)
        If Not IsError(m) Then
            'got a date match - add the shipment to the next available slot
            ws.Cells(m, Columns.Count).End(xlToLeft).Offset(0, 1).Value = shipment
        End If
    Next i
        
End Sub

Excel VBA - 将基于两个参数的数据复制到另一个工作表中

Excel VBA - Copying data based on two parameters into another worksheet

excel

vba

transpose