Question

我试图在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

Answer 1

每次粘贴时，您都需要确定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

Answer 2

您应该将代码分成较小的单元。子例程执行的任务越少，读取，修改和调试就越容易。

请注意，我的代码允许您测试向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

遍历多个工作表时如何写到目标工作表的下一行

2 个答案:

示例代码