Question

我在Excel中有一个列表，我需要从中筛选并将数据从工作簿复制到一堆新的（尚不存在的）工作簿中。这是需要做的事情：

在主文件中，有一个由A-Z列组成的表。在A列中，有250个唯一的不同值用于对数据进行排序。该列表需要遍历并由A列中的每个值过滤。使用每个过滤操作时，应该复制共享相同值的所有行（以及列标题）并粘贴到新工作簿中。需要使用A列中的值来创建和命名新工作簿。

我是VBA的新手，非常感谢您的帮助。

编辑：这是我尝试在其他论坛上找到的一些代码（在mrexcel.com上归功于WarPigl3t）。它似乎可以满足我的所有需求（还有一些不需要的带有时间戳的额外内容）。但是，宏的.SaveAs部分由于某种原因而失败。

Sub CopySelectedData()
nameColumn = "A"
headerRow = 1
firstRow = 2

mainWB = getWorkbookName(ThisWorkbook.Name)
mainSht = ActiveSheet.Name
lastRow = Workbooks(mainWB).Sheets(mainSht).Range("A"  & Rows.Count).End(xlUp).Row
filePath = getFilePath(ActiveWorkbook)
timeStamp = getTimeStamp()
Call createNewDirectory(filePath, timeStamp)
arrayOfNames = createArrayOfNames(mainWB, mainSht, firstRow, lastRow, nameColumn)
Call createNewWorkbook(mainWB, mainSht, nameColumn, headerRow, firstRow, lastRow, filePath, timeStamp, arrayOfNames)
End Sub

Function getWorkbookName(WB_Name)
mySplit = Split(WB_Name, ".")
getWorkbookName = mySplit(0)
End Function

Function getFilePath(WB) As String
getFilePath = WB.Path
End Function

Function getTimeStamp()
myNow = Now
myNow = Replace(myNow, "/", "-")
myNow = Replace(myNow, ":", "`")
getTimeStamp = myNow
End Function

Sub createNewDirectory(filePath, folderName)
MkDir (filePath & "/" & folderName)
End Sub

Function createArrayOfNames(mainWB, mainSht, firstRow, lastRow, nameColumn)
a = 0
Dim myArrayOfNames() As String
ReDim Preserve myArrayOfNames(a)
r = firstRow
Do Until r > lastRow
    myValue = Workbooks(mainWB).Sheets(mainSht).Range(nameColumn & r).Value
    addNewElementToArrayOfNames = True
    For Each element In myArrayOfNames()
        If element = myValue Then
            addNewElementToArrayOfNames = False
        End If
    Next element
    If addNewElementToArrayOfNames = True Then
        ReDim Preserve myArrayOfNames(a)
        myArrayOfNames(a) = myValue
        a = a + 1
    End If
    r = r + 1
Loop
createArrayOfNames = myArrayOfNames()
End Function

Sub createNewWorkbook(mainWB, mainSht, nameColumn, headerRow, firstRow, lastRow, filePath, timeStamp, arrayOfNames)
For Each element In arrayOfNames
    Set newWB = Workbooks.Add
    With newWB
        .SaveAs Filename:=filePath & "\" & timeStamp & "\" & element & ".xls"
        newWB_Name = getWorkbookName(newWB.Name)
        Call createMonthlyData(newWB_Name, mainWB, mainSht, nameColumn, headerRow, firstRow, lastRow, element)
        newWB.Save
        newWB.Close
    End With
Next element
End Sub

Sub createMonthlyData(newWB_Name, mainWB, mainSht, nameColumn, headerRow, firstRow, lastRow, arrayName)
Workbooks(mainWB).Sheets(mainSht).Rows(headerRow).Copy
ActiveSheet.Paste Destination:=Workbooks(newWB_Name).Sheets("Blad1").Rows(headerRow)
nextRow = firstRow
r = firstRow
Do Until r > lastRow
    nameValue = Workbooks(mainWB).Sheets(mainSht).Range(nameColumn & r).Value
    If nameValue = arrayName Then
        Workbooks(mainWB).Sheets(mainSht).Rows(r).Copy
        ActiveSheet.Paste Destination:=Workbooks(newWB_Name).Sheets("Blad1").Rows(nextRow)
        nextRow = nextRow + 1
    End If
    r = r + 1
Loop
End Sub

用于将所选数据复制到新工作簿的VBA

0 个答案: