VBA根据2个单独工作表中的值复制范围

Question

我不知道我做错了什么。代码将运行，但它不会按预期复制数据，所有值似乎都覆盖到目标工作表 (tsht( 上的第 1 行，而不是将数据复制到目标工作表。此处的目标是获取数据，并为组 ID 选项卡上列出的每个县(由 SubCell.Value 捕获(迭代数据。如果计划代码和期限日期匹配，宏应将 gsht 上指定数量的县的每个匹配行从 dsht 复制到 tsht。任何人都可以看到我的错误或为什么此代码将数据全部保留在 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

这已经通过下面的代码解决了，我想发布解决方案，以防有人找到让这段代码为他们工作的方法。抱歉，我无法将其复制为我的第一个块一样干净。

溶液：

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 =

应该是

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