创建多个新工作簿并根据单元格值复制行

Question

我在A5的A列中有一个Excel文档，其中包含区域列表（Område是瑞典语的“区域”）。然后在B5到AZ5列（将来可能还会有更多）中，我有名字。如果名称下方有“ x”，则它们负责相应的区域。可能存在只有一个“ x”，多个“ x”或没有“ x”的区域。 第1-3行包含我按下以浏览电子表格的按钮，第4行为空，但这仅仅是化妆品。

Example of how the source Excel document looks

我的想法是什么。浏览文档并查找“ x”。创建一个新文档，其中列出的A列中的Areas和第5行中的Name作为文件名。我还希望将单元格A5复制到新文档中的单元格A1中，单元格B1应该包含“名称”，而单元格C1应该包含当前日期，因此我知道文件的创建时间。

Example on how the new document should look

我在很多Googling上都可以使用它，但是...作为VBA的新手，我认为它不是一个非常有效的代码。

我做什么。

1. 看起来B5单元格中包含一些东西
2. 创建新的工作表并将信息从源A5和B5复制到A1和B1，并在新文件中将日期设置为C1
3. 在源中查找“ x”，并将带有“ x”的行复制到新的第一行，然后将B2的内容清除到新的BB300中，以消除所有的“ x”。 / li>
4. 创建一个新工作簿并将新工作表移至新工作簿并保存。
5. 为单元格C5，D5等重复1-4，直到AZ5。

我最多可以重复33次，然后该项目使用了超过64K的数据，所以我将其拆分为两个按钮，一个按钮用于B到Z，然后一个按钮用于AA到AZ。 我当前代码的示例

Dim wsSource As Worksheet
Dim wsNewSht1 As Worksheet
Dim FName           As String
Dim FPath           As String
Dim NewBook         As Workbook
Dim Answer As String
Set wsSource = Worksheets(1)
FPath = "C:\Listor" 'Which path to save to
Datum = "yy-MM-DD" 'Format for the date in C1
Rensa = "B2:BB300" 'Deletes everything from B2 to BB300 so you get rid of un-needed "x". Shange if you need more or less


If IsEmpty(Range("B5")) = False Then 'Start of Kolumn B

Set wsNewSht1 = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'Adds a new sheet last
wsNewSht1.Name = "A"      'Renames the new sheet to "A"
wsSource.Range("A5").Copy Destination:=wsNewSht1.Range("A1") 'Copying Cell A5 to the new sheet so you get the "Area"
wsSource.Range("B5").Copy Destination:=wsNewSht1.Range("B1") 'Copying Cell B5 to the new sheet so you get the name from B5
wsNewSht1.Cells(1, 3).Value = Format(Now, Datum) 'Adds today's date in cell C1
a = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row 'Counts how many rows in column A that are in use

For i = 2 To a
    If Worksheets(1).Cells(i, 2).Value = "x" Then 'If "x" is in the column B...
        Worksheets(1).Rows(i).Copy 'Copying the rows containing "x"
        Worksheets("A").Activate 'Activates sheet "A"
        b = Worksheets("A").Cells(Rows.Count, "A").End(xlUp).Row 'Counts where the first empty cell is
        Worksheets("A").Cells(b + 1, 1).Select 'Choose where to paste
        ActiveSheet.Paste 'Paste the copied rows to the active sheet("A")
        ActiveSheet.Range(Rensa).Clear 'Removes all "x" from sheet "A"
    End If
 Next i

    Set NewBook = Workbooks.Add 'Creates the new file to where we will move the sheet "A" to.
    ThisWorkbook.Sheets("A").Move After:=NewBook.Sheets(1) 'Moves the sheet "A" to the new file
    Application.DisplayAlerts = False 'Disables popup alerts for the next line
    NewBook.Worksheets(1).Delete 'Removes the original sheet from the new workbook, so our moved one is the only
    Application.DisplayAlerts = True 'Enables popup alerts again
    Application.Goto Reference:=Worksheets("A").Range("A1"), Scroll:=True 'Goes to the top of the document
    Worksheets("A").Activate 'Activates sheet "A"
    FName = Sheets(1).Range("B1") & ".xlsx" 'Sets the filename to the content of cell B1 and add file extension xlsx
            If Dir(FPath & "\" & FName) <> "" Then
            MsgBox "File " & FPath & "\" & FName & " already exists" 'If the filename already exists
        Else
            NewBook.SaveAs Filename:=FPath & "\" & FName 'Saving he new document in "FPath" as "FName"
        End If

    NewBook.Close
Application.CutCopyMode = False 'emptying clipboard
Else
    Answer = MsgBox("Cell B5 is Empty." & vbNewLine & "Do you want to check cell C5?", vbQuestion + vbYesNo, "The cell is empty")
    If Answer = vbNo Then
        Application.DisplayAlerts = False
        Exit Sub
    Else
        End If

End If 'End of column B

'After here it runs the same code with minor changes to check the next column and so, from C5, D5, E5 and on to AZ5

If IsEmpty(Range("C5")) = False Then

我知道的东西可以优化，但是我不知道如何。

1. 无需粘贴所有“ x”，然后清除文档的很大一部分，但我还没有想过仅粘贴“ A”列的内容
2. 如果没有“ x”，我仍将使用名称和日期创建一个新文档，但是当然没有区域。如果没有“ x”，我根本不需要新文档。我猜可以用一些更聪明的If AND Else来解决。
3. 我想我可以跳过创建新工作表，而直接进入新工作簿。
4. 虽然1、2和3是次要的装饰，但我的大问题是： 我认为可以这样：如果单元格B5包含名称，并且在B列中至少有一个“ x”，则“运行这段创建新文档的代码”，否则/否则，出现一个消息框，询问我是否要检查下一个单元格（在本例中为C5），并自动执行此操作，直到第5行的下一个空单元格为止。

真正的问题是：我可以在不检查我想检查的每一列的代码的情况下重复此操作吗？

我进行了搜索，但是到目前为止结果还算运气不佳，我可能只是不知道正确的搜索词而已。我将不胜感激，如果能获得帮助，或者如果曾经有人问过/回答过同样的事情，我将不胜感激要搜索的链接或术语。