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

Question

I'm trying to copy data from one sheet that contains raw data (over 30 columns and 300000 rows) into other sheets that split them into organized form.
In the DATA sheet I have repetitive ID's in column A, case numbers in column B which are unique and dates of cases in column J (multiple case numbers have the same date).
My goal is to copy case numbers into worksheets that are named with ID's from col A. In the target sheet I have single dates in col A (ex. from 3/01/2021 in A1 to 3/31/2021 in A31). The case numbers need to be transposed so they appear in columns next to each other but they have the same date.
I cannot use the ID's names in the code because it varies every month so I suppose that the code needs to work as some sort of comparison tool.

Answer 1

This should be close: it will add the sheets if they don't already exist.
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