Excel 如何编写代码，根据单元格值将数据拆分到多个工作簿中

VBA/宏按钮，根据列值将数据拆分到多个工作簿中

需要VBA或宏按钮来选择文件，并根据列值将数据拆分为多个文件

我确实有一个宏文件，其中的代码是，当我将数据粘贴到原始数据表中并单击按钮时，它将要求选择文件的标题，并且我需要再次输入列标题，在其中我需要根据该列拆分数据，并且数据将在同一文件上分离

因此，我需要宏或VBA按钮基于以下给定的要求。请在这方面帮助我

当我点击宏按钮时，弹出窗口将打开，从本地驱动器中选择报告。报告将采用.xls或.xlsx或.csv格式 -一旦我选择了报告，它应该要求输入列标题名称。 -输入列标题名称后，需要根据选定列上的唯一单元格值将数据拆分为多个工作簿。 -在保存文件之前，逗号应替换为分号；在给定工作簿上的任何单元格中。

---

-拆分的工作簿应命名为单元值-宏工作簿名称。文件应以.csv格式保存

---例如：宏工作簿名为Book1，我的单元格值为ABC、BCA、DAB。因此，当我将数据拆分为多个工作簿时，它的名称应如下所示

ABC-第1册 BCA-第1册 DAB-第1册

如果您需要任何进一步的细节，请告诉我

目前它没有拆分为多个工作簿

````
Private Sub CommandButton1_Click()
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
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Raw Data", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Raw Data", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) 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
xWSTRg.Range(title).Copy
Sheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub

````

这有什么帮助吗

Sub DistributeCells(Sourcews As Worksheet, colLetter As String, startrow As Long)
'Takes data from Sourcews and places each row into a sheet named as the contents of that row in the column identified by ColLetter
'beginning at startrow
Dim r As Range

Set r = Sourcews.Range(colLetter & startrow) 'start here
Do
    AddIfMissing (r) 'create sheet if needed
    r.EntireRow.Copy Sheets(r).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) 'copy row
    Set r = r.Offset(1, 0)
Loop Until r = ""
End Sub

Sub AddIfMissing(r As Range)
On Error GoTo nope
Dim sheetname As String
sheetname = r.Text

Dim ws As Worksheet
Set ws = Worksheets(sheetname) 'won't error if sheet exists
Exit Sub
nope:
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ws.Name = sheetname
r.Parent.Range("a1").EntireRow.Copy ws.Range("a1") 'copy headers from source
End Sub

---

请粘贴您现有的code@HarassedDad-我已更新了代码，如果您需要，我将向您发送excel文件。我需要在其中添加上述给定代码，无论是在命令按钮上还是在活动工作表上。实际上，我需要一个带有命令按钮的宏文件，宏代码应分配给该按钮，因此其工作方式如下--单击命令按钮后，弹出窗口将打开，以从本地驱动器请求源文件-无论它是否为.csv/.xls/.xlsx格式，都应该可以工作---选择文件后，文件中的逗号应替换为分号；再次弹出窗口，输入列标题名称以拆分数据---输入列标题后，需要根据列值将数据拆分为多个工作簿。拆分后的工作簿应命名为单元格值-宏工作簿名称。文件应以.csv格式保存。请根据我的要求帮助我