VBA将零行群复制到特定的工作表

Question

我正在发出此代码工作的问题。它应该通过A列A，直到找到"员工"的下一个实例，然后将这些行复制到C列中指定的工作表，然后继续向下返回列表。我是VBA的新手，有人可以帮我吗？

员工信息在"员工"一词的每两个实例之间

向大家道歉，很明显我是新的。我使用代码的目标是将一个范围从一张纸（" regs"）复制到列范围内的一个单元格中指定的另一个表格。该范围从5到16行高，每个范围都有2行，每个范围都被2夹住。A栏中"员工"的实例：一个与"员工：#####"，lname，fname"的实例，一个带有"员工总计"的实例。我的具体问题是将循环设置为复制每个范围后的变量数量（可变量为先前复制范围的行＃）。

我偶然发现了一个解决方案，我肯定会做得更好。

Sub HourAllocationsRegs()
    Dim StartRow As Integer
    Dim EndRow As Integer
    Dim lngLastRow As Long
    Dim strMyValue As String
    strMyValue = "Employee" 'Value to search for, change as required.
    Sheets("Regs").Select
    lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row 'Search Column A, change as required.
    For i = 2 To lRow Step K - i 'Starts on Row 7 and will jump to the next group according to row of next value
        StartRow = i
        For K = i + 1 To 100 Step 1
            If InStr(1, (Range("A" & i + 1).Value), strMyValue) > 0 Then
                EndRow = K
                Exit For
            End If
        Next
        Rows(Str(StartRow) & ":" & Str(EndRow)).Select
        Selection.Copy
        Sheets(Range("C" & Str(StartRow + 2)).Text).Select
        Range("A1048576").End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
    Next
End Sub

Answer 1

这是您无需选择工作表的方法。

Sub HourAllocationsRegs2()
    Dim lngLastRow As Long, x As Long, x1 As Long
    Dim SheetName As String, strMyValue As String
    strMyValue = "Employee"                           'Value to search for, change as required.
    With Worksheets("Regs")
        lngLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        For x = 2 To lngLastRow
            If InStr(1, .Cells(x, 1), strMyValue) > 0 Then
                For x1 = x + 1 To lngLastRow
                    If x1 = lngLastRow Or InStr(1, .Cells(x1 + 1, 1), strMyValue) > 0 Then
                        SheetName = .Cells(x + 1, 1).Value
                        .Rows(x & ":" & x1).Copy Destination:=Worksheets(SheetName).Range("A" & .Rows.Count).End(xlUp).Offset(1)
                        x = x1
                        Exit For
                    End If
                Next
            End If
        Next
    End With
End Sub

Answer 2

想到的第一件事就是使用。如果您有发现问题，则可以使用：

Dim i, j, k, LR as Integer
j=0
k=0
LR = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 to LR
    If Cells(i,1).Value="Employee" Then
        If k=0 And j=0 Then
            k=Cells(i,1).Row
        Else 
            If j=0 Then
                j=Cells(i,1).Row
            Else
            End If
        End If
    Else
    End If
Next i
DestinationRange.Value = Range(Rows(k+1),Rows(j-1)).Value 'Destination range is where you want to be; not defined

Answer 3

花了几个小时，然后偶然发现了解决方案。如果您可以做得更好，请编辑！

Sub HourAllocationsRegs()
Dim strStartRow As String
Dim strEndRow As String
Dim strRefRow As String
Dim lngLastRow As Long
Dim strMyValue As String
Application.ScreenUpdating = False
strMyValue = "Employee Totals" 'Value to search for, change as required.
Sheets("Regs").Select
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row 'Search Column A, change as required.
For i = 7 To lngLastRow Step (K - lngStartRow + 1) 'Starts on Row 7 and will jump to the next group according to row of next value
    strStartRow = (i + K - lngStartRow)
    strRefRow = (i + K - lngStartRow + 3)
    For K = Val(strStartRow) To lngLastRow Step 1
        If InStr(1, (Range("A" & K).Value), strMyValue) > 0 Then
            strEndRow = K
            Rows(strStartRow & ":" & strEndRow).Select
            Selection.Copy
            Sheets(Range("C" & strRefRow).Text).Select
            Range("A1048576").End(xlUp).Offset(1, 0).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Sheets("Regs").Select
            lngStartRow = i
            Exit For
        End If
    Next
Next
End Sub