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

我一直在search有关使用macros来复制行并粘贴到Excel中的新工作表的post，但我似乎无法find符合我的要求的正确的代码。 下面是一个示例数据开始：

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

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

我想创build一个macros，它将根据COLUMN A – DEPARMENT拆分这个表单的内容，并将它们放在不同的表单上，新的表单将被命名为A列中的部门名称。

最终的结果应该是这样的：

这是迄今为止的代码。 它检查每一行，如果列A中的单元格等于它下面的下一个单元格，则select该行。 现在我怎样才能使select留下来，并添加更多的选定的行，因为它检查列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 

Answer 1

你已经提出了一个很好的问题。 对起点和目标有明确的描述。 你的代码是答案的好开始。 但是，我没有试图像你想做的那样把一堆行组合在一起，因为我不知道如何做到这一点。 我所做的就是循环访问DATA范围，然后逐行处理每一行。 如果目标工作表存在，我插入最后一行之后的行。 如果目标工作表不存在，我按照自己的方式创build新工作表。 通过debugging器来完成这一步，你将能够看到它是如何工作的。

 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 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

感谢你的回复。 实际上，我发现了一个相当不错的代码，但是我忘了记下参考网站。 如果任何人感兴趣，这里是代码：

  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 4

我已经创build了这个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