vba 根据单元格值复制行并粘贴到具有相同单元格值名称的新工作表上
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/38796106/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Copy rows based on cell value and paste on a new sheet with same cell value name
提问by Eileen
I have a DATA sheet containing an employee list with 3 columns,
我有一个包含 3 列员工列表的数据表，
COLUMN A - DEPARTMENT
COLUMN B - EMPCODE
COLUMN C - EMPNAME
Here is sample data:
这是示例数据：
I want to split the contents of this sheet according to COLUMN A - DEPARMENT and place them on different sheets, the new sheets to be named as the department name in Column A.
我想根据 COLUMN A - DEPARMENT 拆分此工作表的内容并将它们放在不同的工作表上，新工作表将命名为 A 列中的部门名称。
The end result should be something like this:
最终结果应该是这样的：
This code checks each row. If the cell in Column A is equal to the cell below, it selects the row.
此代码检查每一行。如果 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
How can I make the selection stay and add more selected rows as it checks the cell value in Column A?
在检查 A 列中的单元格值时，如何使选择保持不变并添加更多选定的行？
回答by Vishal Agrawal
I've created this VBA to copy data from one sheet (source) to another sheet (target) based on conditional data given in 3rd sheet (condition):
我创建了这个 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
回答by Ravi Chandran
But Eileen, If we need to copy cell values of COLUMN E, rather than COLUMN A and paste on new sheet, then your ref code still lists values from COLUMN A......! So we need just to change vcol = 5 on line 9
但是艾琳，如果我们需要复制 COLUMN E 的单元格值，而不是 COLUMN A 并粘贴到新工作表上，那么您的参考代码仍然列出了 COLUMN A 中的值......！所以我们只需要在第 9 行更改 vcol = 5
回答by dev1998
You've put together a pretty good question. It has a clear description of the starting point and what the objective is. The code you have is a good start towards the answer. However I didn't try to group a bunch of rows together like you wanted to do because I had no idea of how to do that. What I did was to loop through the DATA range and then deal with each row one at a time. If the destination worksheet existed, I inserted the row after the last row. If the destination sheet did not exist, I created the new sheet the way you were doing. Step through this with the debugger and you'll be able to see how it works.
你提出了一个很好的问题。它清楚地描述了起点和目标是什么。您拥有的代码是答案的良好开端。但是，我并没有像您想要的那样尝试将一堆行组合在一起，因为我不知道该怎么做。我所做的是遍历 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
回答by user3598756
you can use RemoveDuplicates()and Autofilter()methods of Range object as follows:
您可以使用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
回答by Eileen
Thanks for all your replies. I actually found a pretty good code that does exactly what I wanted, I forgot to note down the reference site though. Here's the code if anyone's interested:
感谢你的回复。我实际上找到了一个很好的代码，它完全符合我的要求，但我忘了记下参考站点。如果有人感兴趣，这是代码：
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
