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

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

1）在文件目录中做这个？

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

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