Suggestions for optimizing code that sorts data into multiple sheets - needs to be faster for 100k+ rows - excel

Question

How could I make my code faster...? I tried two different approaches to achieve what I need to, but they are rather slow when I work with ~140,000 rows of data.
The data is found in one sheet, and four additional sheets exist which have the names
LogName(1) = "Log_1"
LogName(2) = "Log_2"
LogName(3) = "Log_3"
LogName(4) = "Custom_Log"
LogNameSz = UBound(LogName) - LBound(LogName) + 1
Each data row contain one of these labels per row, and all of these labels are in the same column (see example below):
enter image description here
The spirit of the code is the following: for each row, look at the row's label, copy the entire row of data, and paste it into the sheet with the corresponding name.
These are my approaches:
''FIRST METHOD
'For j = 1 To LogNameSz
' cnt = 4
' Set celE = ColLog.Find(LogName(j), LookIn:=xlValues)
' fstadd = celE.Address
' 'Debug.Print fstadd
' Do
' celE.EntireRow.Copy Worksheets(LogName(j)).Rows(cnt)
' Set celE = ColLog.FindNext(celE)
' cnt = cnt + 1
' Loop While celE.Address <> fstadd
'Next j
''SECOND METHOD
' For s = 1 To Lastrworig
' If CkList(ColLog.Rows(s).Value, LogName, LogNameSz) = True Then
' Set ColEValue = Worksheets(ColLog.Rows(s).Value).UsedRange
' Lastrwlog = ColEValue.Row + ColEValue.Rows.count - 1
' ColLog.Rows(s).EntireRow.Copy Worksheets(ColLog.Rows(s).Value).Rows(Lastrwlog + 1)
' End If
' Next s
The reason why cnt = 4 is because the four additional sheets have 3 rows that have been added to the top of the sheets, and the data needs to be pasted starting on the 4th row. This is also the same reason why I look for the last row of each sheet by using UsedRange in my second method.
Does anyone one have suggestions for how to make either of these methods faster?

Answer 1

Copy +100k Criteria Rows
Sub CopyData()
Const SRC_NAME As String = "Master"
Const SRC_CRITERIA_COLUMN As Long = 5
Const SRC_FIRST_CELL As String = "A2"
Const DST_FIRST_CELL As String = "A4"
Dim dNames(): dNames = VBA.Array("Log_1", "Log_2", "Log_3", "Custom_Log")
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range
With sws.UsedRange
Set srg = sws.Range(SRC_FIRST_CELL, .Cells(.Rows.Count, .Columns.Count))
End With
Dim cCount As Long: cCount = srg.Columns.Count
Dim sData(): sData = srg.Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim dKey
For Each dKey In dNames
Set dict(dKey) = New Collection
Next dKey
Erase dNames
Dim sr As Long, srString As String
For sr = 1 To UBound(sData, 1)
srString = CStr(sData(sr, SRC_CRITERIA_COLUMN))
If dict.Exists(srString) Then dict(srString).Add sr
Next sr
Dim dws As Worksheet, dData(), srItem, dr As Long, c As Long
For Each dKey In dict.Keys
ReDim dData(1 To dict(dKey).Count, 1 To cCount)
dr = 0
For Each srItem In dict(dKey)
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = sData(srItem, c)
Next c
Next srItem
Set dws = wb.Sheets(dKey)
dws.Range(DST_FIRST_CELL).Resize(dr, cCount).Value = dData
Next dKey
MsgBox "Data copied.", vbInformation
End Sub