[英]Copy rows based on cell value and paste on a new sheet with same cell value name
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 列中的单元格值时,如何使选择保持不变并添加更多选定的行?
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
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
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.
我所做的是遍历 DATA 范围,然后一次处理每一行。 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.
使用调试器逐步完成此过程,您将能够看到它是如何工作的。
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
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
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......!但是艾琳,如果我们需要复制 COLUMN E 的单元格值,而不是 COLUMN A 并粘贴到新工作表上,那么您的参考代码仍然列出了 COLUMN A 中的值......! So we need just to change vcol = 5 on line 9
所以我们只需要在第 9 行更改 vcol = 5
I modified user3598756's answer above to bypass restrictions on the max length allowed for the name of a sheet.我修改了上面user3598756 的答案,以绕过对工作表名称允许的最大长度的限制。 It will concatenate the first and last 13 characters of the name with 4 dots in between
它将连接名称的前 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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.