Как написать код для разделения данных на несколько книг на основе значения ячейки

Question

Кнопка VBA / Macro для разделения данных на несколько рабочих книг на основе значения столбца

Требуется кнопка VBA или Macro для выбора файла и разделения данных на несколько файлов на основе значения столбца.

У меня есть файл макроса с кодом, в котором, когда я вставляю свои данные в лист данных Raw и нажимаю на кнопку, он попросит выбрать заголовки в файле, и снова мне нужно ввести заголовок столбца, где мне нужноразделить данные на основе этого столбца, и данные разделяются на один и тот же файл.

Поэтому мне нужна кнопка Macro или VBA на основе приведенных ниже требований. Пожалуйста, помогите мне в этом.

Когда я нажимаю на кнопку макроса, должно открыться всплывающее окно, чтобы выбрать отчет с моего локального диска (отчет будет в формате .xls или .xlsx или .csv) - один разЯ выбрал отчет, который должен запрашивать имя заголовка столбца для ввода. - После ввода имени заголовка столбца данные необходимо разделить на несколько рабочих книг на основе уникального значения ячейки в выбранном столбце. - перед сохранением файла запятую "," следует заменить точкой с запятой ";"в любой ячейке данной рабочей книги. - разделенная рабочая книга должна называться «значение ячейки - имя рабочей книги макроса». и файл должен быть сохранен в формате .csv

----- например: имя рабочей книги макроса - "Book1", и у меня есть значение ячейки, такое как "ABC", "BCA", "DAB",поэтому, когда я разделяю данные на несколько рабочих книг, они должны называться следующим образом.

ABC - Book1 BCA - Book1 DAB - Book1

Пожалуйста, дайте мне знать, если вам нужна дополнительная информация

В настоящее время он не разделяется на несколько рабочих книг.

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

````

Answer 1

Это какая-нибудь помощь?

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