Question

我有下面的例程，如果工作表名称与数组名称匹配，我将复制工作表的所有内容。

我已将表单复制到目的地，但我没有让数组值curRow递增。

我在这里缺少什么？

Sub test()

    Dim curRow As Integer, CurrentRow As Integer, LastRow As Integer, LastRow2 As Integer
    Dim activeWorksheet As Worksheet
    Set activeWorksheet = ActiveSheet
    Dim ws As Worksheet
    Dim arArray As Variant

    Sheets("Total Tabs").Activate
    arArray = Sheets("Total Tabs").Range("A1", Range("A" & Rows.Count).End(xlUp))

    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    curRow = 1
    CurrentRow = 2

    For curRow = 1 To LastRow

        For Each ws In ActiveWorkbook.Worksheets
'            If curRow <> 1 Then
 '               curRow = curRow + 1

 '          End If

            If ws.name = arArray(curRow, 1) Then
                LastRow2 = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
                For CurrentRow = 2 To LastRow2
                    ws.Range("A" & CurrentRow & ":N" & CurrentRow).Copy Destination:=Sheets("Reps No Longer Here").Range("A" & CurrentRow)

                    CurrentRow = CurrentRow + 1
                Next
                    curRow = curRow + 1
            End If

        Next ws
    Next curRow

End Sub

更新：这是我拥有的最终代码并且应该正常工作。包括还可以在标签处理后隐藏标签。

我确定它可以进行优化，但现在是：

Sub CombineDataToRNLH()

    Dim curRow As Integer, CurrentRow As Integer, LastRow As Integer, LastRow2 As Integer
    Dim activeWorksheet As Worksheet
    Set activeWorksheet = ActiveSheet
    Dim ws As Worksheet
    Dim arArray As Variant
    Dim pasterow As Integer
    Dim RepName As String

'Activate the sheet with the list and then read the list of names
'straight into an array

    Sheets("Total Tabs").Activate
    arArray = Sheets("Total Tabs").Range("A1", Range("A" & Rows.Count).End(xlUp))

'Find last element in the array and calculate as rows

    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    curRow = 1      'Index for evaluating array elements
    CurrentRow = 2  'Counter for use in processing all rows in matched sheet to destination sheet

    LastRow2 = 1    'Find number of rows in the matched tab
    pasterow = 2    'Counter to ensure that I'm always copying data to the first available row

'Set up loop so that I can match array elements to individual sheet names

    For curRow = 1 To LastRow

        For Each ws In ActiveWorkbook.Worksheets

            If ws.name = arArray(curRow, 1) Then
                LastRow2 = ws.Range("A" & Rows.Count).End(xlUp).Row
                For CurrentRow = 2 To LastRow2
                    ws.Range("A" & CurrentRow & ":N" & CurrentRow).Copy _
                    Destination:=Sheets("Reps No Longer Here").Range("A" & pasterow)

                    If CurrentRow = LastRow2 Then
                        curRow = curRow + 1
                        pasterow = pasterow + 1
                        ws.Visible = xlSheetVeryHidden 'Set it to very hidden.

                        Exit For
                    End If

                    pasterow = pasterow + 1

                Next


            End If
        Next ws
    Next curRow
    Sheets("How To").Activate

End Sub

Answer 1

我认为您的代码可以简化并简化一些。从我收集的内容中，您想要遍历一些工作表（如aaArray变量中所定义）并将数据复制到＆＃34; Reps No Longer Here＆＃34;标签。看看这是否符合您的要求：

Sub test()

    Dim LastRow     As Long, _
        LastRow2    As Long

    Dim ws          As Worksheet
    Dim arArray     As Variant
    Dim sheetName   As Variant

    With Application
        .ScreenUpdating = False
    End With

    With Sheets("Total Tabs")

        arArray = .Range("A1", .Range("A" & Rows.Count).End(xlUp))

        For Each sheetName In arArray
            On Error Resume Next
            Set ws = Sheets(sheetName)
            On Error GoTo 0
            If ws Is Nothing Then
             ' we don't need to do anything since the sheet doesn't exist
            Else

                LastRow2 = ws.Range("A" & Rows.Count).End(xlUp).Row
                LastRow = Sheets("Reps No Longer Here").Range("A" & Rows.Count).End(xlUp).Row + 1
                ws.Range("A2:N" & LastRow2).Copy Destination:=Sheets("Reps No Longer Here").Range("A" & LastRow)
            End If

        Next sheetName
    End With

    With Application
        .ScreenUpdating = True
    End With
End Sub

如何在此代码中递增数组计数器以移动到数组中的下一个元素？

1 个答案: