vba 根据单元格值将行移动到现有/新工作表
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/17399746/
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
Move rows to existing/new worksheet based on cell value
提问by user2538167
what I need is fairly simple but I can't for the life of me figure out how to write this in code. I tried looking around for a macro that could do this, but so far no luck.
我需要的是相当简单的，但我一生都无法弄清楚如何在代码中编写它。我试着四处寻找可以做到这一点的宏，但到目前为止还没有运气。
I have a workbook with one worksheet that contains raw data and 30 or so worksheets for different customers. Each row in the raw data worksheet has the name of the customer in column I.
我有一个工作簿，其中包含一个工作表，其中包含原始数据和 30 个左右不同客户的工作表。原始数据工作表中的每一行在 I 列中都有客户的姓名。
I need to make a macro that cuts and pastes each row to the worksheet of the respective customer, for example if I2=CustomerA, move that row to the end of sheet CustomerA. Also some customers don't have worksheets yet because they're new, so for example if I5=CustomerZ but worksheet CustomerZ not found, create it and then move the row.
我需要制作一个宏，将每一行剪切并粘贴到相应客户的工作表中，例如，如果 I2=CustomerA，则将该行移动到工作表 CustomerA 的末尾。此外，有些客户还没有工作表，因为它们是新的，例如，如果 I5=CustomerZ 但未找到工作表 CustomerZ，请创建它然后移动该行。
回答by
All you really have to do is set your :sh33tNameso it matches your master worksheetcustNameColumnso it matches your column name with the customers namesstRowrow at which the customer names start
您真正需要做的就是设置您的 :sh33tName以便它匹配您的主工作表，custNameColumn以便将您的列名称与stRow客户名称开始的客户名称行进行匹配
Option Explicit
Sub Fr33M4cro()
Dim sh33tName As String
Dim custNameColumn As String
Dim i As Long
Dim stRow As Long
Dim customer As String
Dim ws As Worksheet
Dim sheetExist As Boolean
Dim sh As Worksheet
sh33tName = "Sheet1"
custNameColumn = "I"
stRow = 2
Set sh = Sheets(sh33tName)
For i = stRow To sh.Range(custNameColumn & Rows.Count).End(xlUp).Row
customer = sh.Range(custNameColumn & i).Value
For Each ws In ThisWorkbook.Sheets
If StrComp(ws.Name, customer, vbTextCompare) = 0 Then
sheetExist = True
Exit For
End If
Next
If sheetExist Then
CopyRow i, sh, ws, custNameColumn
Else
InsertSheet customer
Set ws = Sheets(Worksheets.Count)
CopyRow i, sh, ws, custNameColumn
End If
Reset sheetExist
Next i
End Sub
Private Sub CopyRow(i As Long, ByRef sh As Worksheet, ByRef ws As Worksheet, custNameColumn As String)
Dim wsRow As Long
wsRow = ws.Range(custNameColumn & Rows.Count).End(xlUp).Row + 1
sh.Rows(i & ":" & i).Copy
ws.Rows(wsRow & ":" & wsRow).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
Private Sub Reset(ByRef x As Boolean)
x = False
End Sub
Private Sub InsertSheet(shName As String)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = shName
End Sub
