VBA copy a range based on values from 2 separate sheets - excel

Question

I do not know what I am doing wrong. The code will run but it does not copy the data as expected, all the values seem to be overwriting to row 1 on the target sheet (tsht) instead of copying data down the target sheet. The goal here is to take data and iterate it for every county listed on the group ID tab (captured by SubCell.Value). Where plan codes and term dates match, the macro should copy each matching row from dsht for the indicated number of counties on gsht to the tsht. Can anyone see my error or why this code is keeping data all in the top row of the tsht?
Sub GroupID_Breakout()
Dim dsht As Worksheet 'data sheet target
Dim gsht As Worksheet
Dim tsht As Worksheet
Dim dlrow As Long
Dim glrow As Long
Dim tlrow As Long
Dim SubCell As Range
Dim rngCell As Range
Dim Result() As String
Dim countycount As Long
Set dsht = ThisWorkbook.Worksheets("Data_No Formulas")
Set gsht = ThisWorkbook.Worksheets("GroupID")
'kill clunky processes
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
'delete compare tab if it exists
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("Data_Final").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'On Error GoTo Errhandler
Sheets.Add(After:=Sheets("Data_No Formulas")).Name = "Data_Final" 'create new tab
Set tsht = ThisWorkbook.Worksheets("Data_Final")
With dsht.Range("A2:CN2")
tsht.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
glrow = gsht.Cells(Rows.Count, 1).End(xlUp).Row
dlrow = dsht.Cells(Rows.Count, 1).End(xlUp).Row
For Each SubCell In gsht.Range("I2:I" & glrow)
countycount = SubCell.Value
Result() = Split(SubCell.Offset(0, -2).Value, ",")
For Each rngCell In dsht.Range("A3:A" & dlrow)
a = 0
If SubCell.Offset(0, -4).Value = rngCell.Value And SubCell.Offset(0, -8).Value = rngCell.Offset(0, 5).Value Then
For i = 1 To countycount
tlrow = tsht.Cells(Rows.Count, 1).End(xlUp).Row
With dsht.Range(rngCell, rngCell.Offset(0, 91))
tsht.Range("A" & tlrow).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
tsht.Range("L" & tlrow).Value = Result(a)
i = i + 1
Next
a = a + 1
End If
Next rngCell
Next SubCell
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Macro Complete!")
Exit Sub
Errhandler:
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Select Case Err.Number
'different error handling here
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Summary"
End Select
End Sub
This has been resolved with the below code, I wanted to post the resolution in case anyone finds a way to make this code work for them. Sorry I couldn't get this to copy over as clean as my 1st block.
Solution:
Sub GroupID_Breakout()
Dim dsht As Worksheet 'data sheet target
Dim gsht As Worksheet
Dim tsht As Worksheet
Dim dlrow As Long
Dim glrow As Long
Dim tlrow As Long
Dim SubCell As Range
Dim rngCell As Range
Dim Result() As String
Dim countycount As Long
Set dsht = ThisWorkbook.Worksheets("Data_No Formulas")
Set gsht = ThisWorkbook.Worksheets("GroupID")
'kill clunky processes
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
'delete compare tab if it exists
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("Data_Final").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'On Error GoTo Errhandler
Sheets.Add(After:=Sheets("Data_No Formulas")).Name = "Data_Final" 'create new tab
Set tsht = ThisWorkbook.Worksheets("Data_Final")
'pull header from dsht to tsht
With dsht.Range("A2:CN2")
tsht.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
glrow = gsht.Cells(Rows.Count, 1).End(xlUp).Row
dlrow = dsht.Cells(Rows.Count, 1).End(xlUp).Row
For Each SubCell In gsht.Range("I2:I" & glrow)
countycount = SubCell.Value
Result() = Split(SubCell.Offset(0, -2).Value, ",") 'separates a list of counties by comma to reference as "Result(0)"
For Each rngCell In dsht.Range("A3:A" & dlrow)
a = 0
i = 1
For i = 1 To countycount
If SubCell.Offset(0, -4).Value = rngCell.Value And SubCell.Offset(0, -8).Value = rngCell.Offset(0, 5).Value Then 'match dates and plan codes
'move row where match is found between dsht and gsht variables
With dsht.Range(rngCell, rngCell.Offset(0, 91))
tlrow = tsht.Cells(Rows.Count, 1).End(xlUp).Row
tsht.Range("A" & (tlrow + 1)).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
'place county names captured by split above with each iteration
tsht.Range("L" & (tlrow + 1)).Value = Result(a)
End If
a = a + 1
Next i
Next rngCell
Next SubCell
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Macro Complete!")
Exit Sub
Errhandler:
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Select Case Err.Number
'different error handling here
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Summary"
End Select
End Sub

Answer 1

tsht.Range("A" & tlrow).Resize(.Rows.Count, .Columns.Count).Value =
should be
tsht.Range("A" & (tlrow+1)).Resize(.Rows.Count, .Columns.Count).Value =