Question

所以我有以下宏，它从具有多个工作表的工作簿的C列中提取唯一值并将其粘贴到新页面。我确实意识到他们是另一个类似的问题，但我不明白。有办法：

1）在文件目录中执行此操作吗？

2）将新值放入主表中，而不是仅在每个文件中创建一个新表：

 Sub extractuniquevalues()
Dim wks As Excel.Worksheet
Dim wksSummary As Excel.Worksheet
'----------------------------------------------------------------------------------

On Error Resume Next
Set wksSummary = Excel.ThisWorkbook.Worksheets("Unique data")
On Error GoTo 0

If wksSummary Is Nothing Then
    Set wksSummary = Excel.ThisWorkbook.Worksheets.Add
    wksSummary.Name = "Unique data"
End If


'Iterate through all the worksheets, but skip [Summary] worksheet.
For Each wks In Excel.ActiveWorkbook.Worksheets

    With wksSummary

        If wks.Name <> .Name Then
            If Application.WorksheetFunction.CountA(wks.Range("C:C")) Then
                Call wks.Range("C:C").AdvancedFilter(xlFilterCopy, , .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1), True)
            End If
        End If

    End With

Next wks

 End Sub

任何帮助都会得到极大的赞赏，谢谢。

Answer 1

您的两个请求都可以完成:(请参阅我的评论）

Sub Main()
    'Turn off alerts like "Do you really want to quit?"
    Application.DisplayAlerts = False

    Call LoopThroughDirectory("D:\Private\Excel\", "*.xls*")

    'Turn alerts on
    Application.DisplayAlerts = True
End Sub

Sub LoopThroughDirectory(dirPath As String, filter As String)
    Dim filename
    'Loop throug all of the files in the given directory
    filename = Dir(dirPath & filter)
    Do While Len(filename) > 0
        ' Filename variable contains the name of the file in the directory
        ' (dirPath & Filename) will be the full path to the file

        ' Lets call here another Sub which will open up workbooks for us.
        OpenAnotherWorkbook (dirPath & filename)

        'Move on to the next file
        filename = Dir
    Loop
End Sub

Sub OpenAnotherWorkbook(filePath As String)
    'Your master workbook to copy to
    Dim master_wb As Workbook
    Set master_wb = ThisWorkbook

    'Your source workbook to copy from
    Dim source_wb As Workbook
    Set source_wb = Application.Workbooks.Open(filePath)

    'Call your subroutine
    Call YourSub(master_wb, source_wb)

    'Close source workbook after everything is done
    source_wb.Close
End Sub

Sub YourSub(master_wb As Workbook, source_wb As Workbook)
    ' Do your stuff here
    '   For example:

    'Find your master sheet
    Dim master_ws As Worksheet
    Set master_ws = GetOrCreateWorksheet(master_wb, "YourSheetName")

    Dim source_ws As Worksheet
    Set source_ws = source_wb.Sheets(1)

    'Lets save some data from the another workbook to the master one.
    Dim lastRowNo As Integer
    lastRowNo = master_ws.UsedRange.Rows.Count
    'If lastRowNo is 1 that means the worksheet is empty or only the headers had been initialized
    If lastRowNo = 1 Then
        'Create headers for the columns
        master_ws.Cells(lastRowNo, 1).Value = "Workbook"
        master_ws.Cells(lastRowNo, 2).Value = "Worksheet"
    End If
    'Give some value to the next empty row's first and second cell
    'Source workbook's name
    master_ws.Cells(lastRowNo + 1, 1).Value = source_wb.Name
    'Source worksheet's name
    master_ws.Cells(lastRowNo + 1, 2).Value = source_ws.Name 

End Sub

Function GetOrCreateWorksheet(wb As Workbook, wsName As String) As Worksheet
    Dim ws As Worksheet
    'Loop through each sheet to find yours
    For Each ws In wb.Sheets
        If ws.Name = wsName Then
            'If found return with it
            Set GetOrCreateWorksheet = ws
            Exit Function
        End If
    Next ws

    'If not exists, create one and return with it
    Set ws = wb.Sheets.Add
    ws.Name = wsName
    Set GetOrCreateWorksheet = ws
End Function

目录的VBA代码和粘贴到主表

1 个答案: