我试图在Excel中编写一个宏,并通过按钮激活该宏,以从大多数为空白的工作表中复制数据行,并且需要将每一行堆叠在目标工作表的下一行下面。随着更多信息的进入,数据将被添加到这些工作表中,并且需要定期进行更新。但是,我似乎无法复制多于两行。
我在合适的区域尝试了row = row + 1。我还尝试了一些在互联网上找到的“最后一行”解决方案,但没有成功。我认为折线是每张纸上通过i和j进行的For循环,但是在使用其他解决方案时我可能犯了一个非常简单的错误。
Sub Update_Model()
Dim trackerWks As Worksheet
Dim dataWks As Worksheet
Dim rg As Range
Dim i As Long
Dim j As Long
Dim rgdataWks As Range
Dim row As Long
Set dataWks = Worksheets("PMD COLLECTION")
Set rgdataWks = dataWks.Range("A3:VD1500")
Dim ws As Worksheet
For Each ws In Worksheets
Select Case UCase(ws.Name)
Case "FLEET STATUS", "CRACK THRESHOLDS", "PMD COLLECTION", "CALCULATIONS"
' do nothing
Case Else
row = row + 1
Set trackerWks = Worksheets(ws.Name)
Set rg = ws.Range("A5:VF150")
For i = 1 To 150
If Not IsEmpty(rg.Cells(row, 1)) Then
For j = 1 To 72
If Not IsEmpty(rg.Cells(i, ((j * 4) + 1))) Then
rgdataWks.Cells(row, (j * 4)).Value2 = rg.Cells(i, ((j * 4) + 1)).Value2
rgdataWks.Cells(row, ((j * 4) + 1)).Value2 = rg.Cells(i, 1).Value2
rgdataWks.Cells(row, ((j * 4) + 1)).NumberFormat = "dd mmm yy"
rgdataWks.Cells(row, ((j * 4) + 2)).Value2 = rg.Cells(i, 3).Value2
rgdataWks.Cells(row, ((j * 4) + 3)).Value2 = rg.Cells(i, ((j * 4) + 3)).Value2
End If
Next j
rgdataWks.Cells(row, 1).Value2 = 1
End If
row = row + 1
Next i
End Select
Next
End Sub
我希望它会在每个j之后以及每个工作表之间写入新行。而是编写第一个工作表的前两行,仅此而已。 我知道工作表循环有效,因为如果删除“ row = row + 1”语句,则只会显示一行,这是最后一个工作表的最后一行。
编辑------------------------------------------------ ---------
使用tinman的建议迭代If语句中的行后,我将所有第一个工作表都放置到目标页面上。但是,下一个工作表不会复制。有人对如何移动下一个工作表有任何建议吗?
这是我的最小可复制示例...我想。我是新手,所以如果您需要更多或更少,请告诉我。
Dim ws As Worksheet
For Each ws In Worksheets
Select Case UCase(ws.Name)
Case "..."
Case Else
Set trackerWks = Worksheets(ws.Name)
Set rg = ws.Range("A5:VF150")
For i = 1 To 150
row = row + 1
If Not IsEmpty(rg.Cells(row, 1)) Then
For j = 1 To 72
If Not IsEmpty(rg.Cells(i, ((j * 4) + 1))) Then
...
...
End If
Next j
End If
Next i
End Select
Next ws
End Sub
答案 0 :(得分:0)
每次粘贴时,您都需要确定destinatino表上的最后一行,类似于:
Dim dest As Worksheet, ws As Worksheet, lrd As Long
Set dest = Worksheets("Dest")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Dest" Then
ws.UsedRange.Copy
lrd = dest.Cells(dest.Rows.Count, 1).End(xlUp).Row 'LAST ROW DEST
dest.Cells(lrd + 1, 1).PasteSpecial xlValues
End If
Next ws
编辑1:
使用上面的示例作为快速示例,表明您要在分配目的地之前找到lrd(最后一行目的地)。这是使用您的代码的东西:
For i = 1 To 150 'CYRIL COMMENT: True Case row loop
If Not IsEmpty(rg.Cells(row, 1)) Then
lrd = rgdataWks.Cells(rgdataWks.Rows.Count,1).End(xlUp).Row 'ADDED, may need to change col A reference
For j = 1 To 72 'CYRIL COMMENT: True Case column loop
If Not IsEmpty(rg.Cells(i, ((j * 4) + 1))) Then
rgdataWks.Cells(lrd+1, (j * 4)).Value2 = rg.Cells(i, ((j * 4) + 1)).Value2
rgdataWks.Cells(lrd+1, ((j * 4) + 1)).Value2 = rg.Cells(i, 1).Value2
rgdataWks.Cells(lrd+1, ((j * 4) + 1)).NumberFormat = "dd mmm yy"
rgdataWks.Cells(lrd+1, ((j * 4) + 2)).Value2 = rg.Cells(i, 3).Value2
rgdataWks.Cells(lrd+1, ((j * 4) + 3)).Value2 = rg.Cells(i, ((j * 4) + 3)).Value2
End If
Next j
rgdataWks.Cells(lrd+1, 1).Value2 = 1
End If
Next i
答案 1 :(得分:0)
您应该将代码分成较小的单元。子例程执行的任务越少,读取,修改和调试就越容易。
请注意,我的代码允许您测试向PMD COLLECTION添加一行,而不必迭代多个工作表中的数据:
AppendPMDRow "testing", 1, 2, 3
您还可以测试单个工作表,而不必遍历所有工作表:
ProcessTrackerWorksheet Worksheets("TestData")
Sub Update_Model()
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In Worksheets
Select Case UCase(ws.Name)
Case "FLEET STATUS", "CRACK THRESHOLDS", "PMD COLLECTION", "CALCULATIONS"
Case Else
ProcessTrackerWorksheet ws
End Select
Next ws
End Sub
Sub ProcessTrackerWorksheet(ws As Worksheet)
Dim r As Long, c As Long
With ws
For r = 1 To .Cells(.Rows.Count, 1).End(xlUp).row
If Len(.Cells(r, 1).Value) > 0 Then
For c = 2 To 72 * 4 Step 4
AppendPMDRow .Cells(r, c).Value, .Cells(r, 1).Value, .Cells(r, 3).Value, .Cells(r, c + 2).Value
Next
End If
Next
End With
End Sub
Sub AppendPMDRow(ParamArray Values() As Variant)
Dim target As Range
With Worksheets("PMD COLLECTION")
Set target = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
target.Resize(1, UBound(Values)).Value = Values
End With
End Sub