如何使用VBA对数据进行分类并传输到其他文件？

Question

我在经营一家卖零食的商店。有50个小吃品牌(品牌A，品牌B，品牌C).)我必须每周向50家不同品牌的供应商提交销售报告。

首先，我有一个原始的excel文件，其中包含日常事务。(还没有按品牌分类)假设A栏是“品牌”，下面的栏是品牌细节，如价格和利润。

由于每个品牌的总销售是自信的，我必须把交易分成50个不同的文件，根据它的品牌，并分别提交。手动这样做需要时间，所以我正在考虑使用VBA代码。

我想，我会做以下几件事

1. 创建50个excel文件并根据品牌命名。
2. 在原始文件中，测试每一行(品牌)的第一个单元格是否与目标文件的名称匹配。如果是，复制该单元格和下一个正确的两个单元格(利润和价格)并粘贴到目标文件。如果不是，跳过那一行。
3. 重复这些操作，直到完成A品牌的数据传输
4. 做品牌B，品牌C等，直到完成50个品牌。

问题是我对VBA是新手，所以我不知道如何开始。

1. 我需要创建多少个VBA工作簿？
2. 如何为“品牌”单元格构造if函数，以查看它是否与目标文件匹配。
3. 我可以使用VBA代码一次创建50个excel工作簿吗？
4. 当我复制单元格时，我如何通过它到目标文件的下一个空行？

​

Answer 1

我基本上是在转储已经存在的代码，我这里已经有供您使用的代码。由于这是远远超过你的问题值得(既然你没有代码分享在一个代码辅助网站)，我不会对此做任何修改。

我会让你去做的--试着理解代码在做什么，并在需要的时候弯曲它以满足你的需要。

宏观..。

1. 确定由Column A确定的唯一值列表
2. 为每个唯一值创建一个新工作表，以便Sheet Name = Unique Value
3. 循环遍历每个新工作表，通过工作表名称(唯一标识符)过滤原始数据，并将所有过滤后的单元格复制/粘贴到各自的工作表中。
4. 下一个宏(需要单独调用)将在主本保存的地方创建一个新文件夹&然后开始将每个工作表作为自己的工作簿保存。

为每一个独特的品牌创建独特的纸张

Sub parse_data()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant

Dim titlerow As Integer
vcol = 1

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

titlerow = ws.Range("A1").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("A1:C" & lr).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

​

为上面创建的每一张纸创建唯一的书籍

' New MACRO

Sub SplitWorkbook()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd")
FolderName = xWb.Path & "\" & "Brands" & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
    xWs.Copy
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        Select Case xWb.FileFormat
            Case 51:
                FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Application.ActiveWorkbook.HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56:
                FileExtStr = ".xls": FileFormatNum = 56
            Case Else:
                FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
    End If



    xFile = FolderName & "\" & "Brands" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
    Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
    Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub

这是我一年前写的，使用它没有任何问题，尽管再看一遍代码，我可以发现可以进行的更新。