根據單元格值復制行並粘貼到具有相同單元格值名稱的新工作表上

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

您可以使用 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 2

我創建了這個 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 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 的答案，以繞過對工作表名稱允許的最大長度的限制。 它將連接名稱的前 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