根据单元格值复制行并粘贴到具有相同单元格值名称的新工作表上

Question

我有一个包含 3 列员工列表的数据表，

COLUMN A - DEPARTMENT
COLUMN B - EMPCODE
COLUMN C - EMPNAME

这里是示例数据：

我想根据 COLUMN A - DEPARMENT 拆分这张表的内容并将它们放在不同的表上，新的表要命名为 A 列中的部门名称。

最终结果应该是这样的：

此代码检查每一行。如果 A 列中的单元格等于下面的单元格，则选择该行。

Sub CopyRows()

    Dim rngMyRange As Range, rngCell As Range
    With Worksheets("DATA")
     Set rngMyRange = .Range(.Range("a1"), .Range("A65536").End(xlUp))

     For Each rngCell In rngMyRange
            If rngCell.Value = rngCell.Offset(1, 0).Value Then
            rngCell.EntireRow.Select
         End If

     Next
         Selection.Copy
         Sheets.Add After:=ActiveSheet
         Rows("1:1").Select
         Selection.Insert Shift:=xlDown
         ActiveSheet.Name = Range("A1")
 End With

 End Sub

在检查 A 列中的单元格值时，如何使选择保持不变并添加更多选定行？

Answer 1

我创建了这个 VBA 以根据第三张表（条件）中给出的条件数据将数据从一张表（源）复制到另一张表（目标）：

Sub CopyYes()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim Condition As Worksheet


    Set Source = ActiveWorkbook.Worksheets("source")
    Set Target = ActiveWorkbook.Worksheets("target")
    Set Condition = ActiveWorkbook.Worksheets("condition")

    j = 1    'This will start copying data to Target sheet at row 1
      For Each d In Condition.Range("A1:A86")
        For Each c In Source.Range("B2:B1893")
            If d = c Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
End Sub

Answer 2

您可以使用 Range 对象的RemoveDuplicates() 和Autofilter() 方法如下：

Option Explicit

Sub CopyRows()
    Dim rngCell As Range
    Dim depSheet As Worksheet

    With Worksheets("DATA") '<--|refer to data sheet
        .Rows(1).Insert '<--|insert a temporary header row: it'll be used for AutoFilter() method and eventually deleted
        .Cells(1, 1).value = "Department" '<--| place a dummy header in the temporary header row
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(, .UsedRange.Columns.Count) '<--| refer to a "helper" column out of the used range and limited to column "A" last non empty row
            .value = .Offset(, -.Parent.UsedRange.Columns.Count).value '<--| duplicate departments (column "A") values in helper one
            .RemoveDuplicates Columns:=Array(1), header:=xlYes '<--| leave only departments unique values in "helper" column
            For Each rngCell In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--|loop through "helper" column departments unique values
                Set depSheet = GetSheet(.Parent.Parent, rngCell.value) '<--|get or add the worksheet corresponding to current department
                With .Offset(, -.Parent.UsedRange.Columns.Count + 1) '<--|refer to departments column
                    .AutoFilter field:=1, Criteria1:=rngCell.value '<--| filter it on current department value
                    With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) '<--| refer to department filtered cells
                        depSheet.Cells(depSheet.Rows.Count, 1).End(xlUp).Offset(1).Resize(.Cells.Count, 3).value = .Resize(, 3).value '<--|copy their values along with columns "B" and "C" ones into first empty row of the corresponding worksheet
                    End With
                End With
            Next rngCell
            .ClearContents '<--| clear "helper" column
        End With
        .AutoFilterMode = False
        .Rows(1).Delete '<--| delete temporary header row
    End With
 End Sub

Function GetSheet(wb As Workbook, shtName As String) As Worksheet
    On Error Resume Next
    Set GetSheet = wb.Worksheets(shtName) '<--| try and set a sheet with passed name
    On Error GoTo 0
    If GetSheet Is Nothing Then '<--| if there weas no such sheet...
        Set GetSheet = wb.Worksheets.Add(After:=ActiveSheet) '<--|... add a new sheet
        With GetSheet
            .Name = shtName '<--|rename it after passed name
            .Range("A1:C1").value = Array("DEPARTMENT", "EMPCODE", "EMPNAME") '<--| add headers
        End With
    End If
End Function

Answer 3

你提出了一个很好的问题。它清楚地描述了起点和目标是什么。您拥有的代码是答案的良好开端。但是，我并没有像您想要的那样尝试将一堆行组合在一起，因为我不知道该怎么做。我所做的是遍历 DATA 范围，然后一次处理每一行。如果目标工作表存在，我会在最后一行之后插入该行。如果目标工作表不存在，我会按照您的方式创建新工作表。使用调试器逐步完成此操作，您将能够看到它是如何工作的。

Sub CopyRows()

Dim rngMyRange As Range, rngCell As Range
Dim sht As Worksheet
Dim LastRow As Long
Dim SheetName As String



With Worksheets("DATA")
Set rngMyRange = .Range(.Range("a1"), .Range("A65536").End(xlUp))

    For Each rngCell In rngMyRange

        rngCell.EntireRow.Select

        Selection.Copy

        If (WorksheetExists(rngCell.Value)) Then
            SheetName = rngCell.Value
            Sheets(SheetName).Select
            Set sht = ThisWorkbook.Worksheets(SheetName)
            LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).row
            Rows(LastRow + 1).Select
            Selection.Insert Shift:=xlDown
        Else
            Sheets.Add After:=ActiveSheet
            Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            ActiveSheet.Name = rngCell.Value
        End If


        'Go back to the DATA sheet
        Sheets("DATA").Select
    Next

End With

End Sub

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

Answer 4

感谢您的所有回复。我实际上找到了一个非常好的代码，它完全符合我的要求，但我忘了记下参考站点。下面是代码，如果有人感兴趣的话：

    Sub parse_data()

    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 1
    Set ws = Sheets("DATA")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:J1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
    Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
    End Sub

Answer 5

但是艾琳， 如果我们需要复制 COLUMN E 的单元格值，而不是 COLUMN A 并粘贴到新工作表上，那么您的参考代码仍然列出来自 COLUMN A 的值......！ 所以我们只需要在第 9 行更改 vcol = 5

Answer 6

我修改了上面的user3598756's answer 以绕过对工作表名称允许的最大长度的限制。它将连接名称的前 13 个字符和后 13 个字符，中间有 4 个点

Option Explicit

Sub CopyRows()
    Dim rngCell As Range
    Dim depSheet As Worksheet
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With Worksheets("DATA") '<--|refer to data sheet
        .Rows(1).Insert '<--|insert a temporary header row: it'll be used for AutoFilter() method and eventually deleted
        .Cells(1, 1).Value = "Table_Name" '<--| place a dummy header in the temporary header row
        With .Range("A1", .Cells(.Rows.count, 1).End(xlUp)).Offset(, .UsedRange.Columns.count) '<--| refer to a "helper" column out of the used range and limited to column "A" last non empty row
            .Value = .Offset(, -.Parent.UsedRange.Columns.count).Value '<--| duplicate departments (column "A") values in helper one
            .RemoveDuplicates Columns:=Array(1), Header:=xlYes '<--| leave only departments unique values in "helper" column
            For Each rngCell In .Range("A2:A" & .Cells(.Rows.count, 1).End(xlUp).Row) '<--|loop through "helper" column departments unique values
                Set depSheet = GetSheet(.Parent.Parent, rngCell.Value) '<--|get or add the worksheet corresponding to current department
                With .Offset(, -.Parent.UsedRange.Columns.count + 1) '<--|refer to departments column
                    .AutoFilter field:=1, Criteria1:=rngCell.Value '<--| filter it on current department value
                    With .Offset(1).Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible) '<--| refer to department filtered cells
                        depSheet.Cells(depSheet.Rows.count, 1).End(xlUp).Offset(1).Resize(.Cells.count, 3).Value = .Resize(, 3).Value '<--|copy their values along with columns "B" and "C" ones into first empty row of the corresponding worksheet
                    End With
                End With
            Next rngCell
            .ClearContents '<--| clear "helper" column
        End With
        .AutoFilterMode = False
        .Rows(1).Delete '<--| delete temporary header row
    End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
 End Sub

Function GetSheet(wb As Workbook, shtName As String) As Worksheet
    On Error Resume Next
    Set GetSheet = wb.Worksheets(shtName) '<--| try and set a sheet with passed name
    On Error GoTo 0
    If GetSheet Is Nothing Then '<--| if there weas no such sheet...
        Dim count As Long
        count = Len(shtName)
        Dim newName As String
        If count > 30 Then
            newName = Left(shtName, 13) & "...." & Right(shtName, 13)
        Else
            newName = shtName
        End If
        Set GetSheet = wb.Worksheets.Add(After:=ActiveSheet) '<--|... add a new sheet
        With GetSheet
            .Name = newName '<--|rename it after passed name
            .Range("A1:C1").Value = Array("DEPARTMENT", "EMPCODE", "EMPNAME") '<--| add headers
        End With
    End If
End Function