如何从驻留在不同文件夹中的多个工作簿复制数据？

问题描述

我正在尝试编写代码来查看由不同个人管理的多个文件，并将特定工作表中的数据复制到我的工作簿/工作表中。

差异 -

每个源工作簿的文件路径不同
每个源工作簿的工作表名称都不同
每个源工作簿的高级过滤器的标准范围不同

我的当前代码适用于指定的文件。我如何修改它以针对 10 个不同的工作簿中的每一个运行，将新数据添加到工作表而不覆盖已经从上一个工作簿复制的数据？

Sub OpenWorkbook()
'Open a workbook

  'Open method requires full file path to be referenced.
Dim sFilename As String
    sFilename = "\\naeamechfs101v\navsea2$\DLGR6\XDP\XDPC\SHARE\Organizational\H Dept\HR Status Spreadsheet-H Dept-FY21_.xlsx"
  
    ' Open workbook as read-only and store in variable wk
    Dim wk As Workbook
    Set wk = Workbooks.Open(sFilename,ReadOnly:=True)
    
 
  'Open method has additional parameters
  'Workbooks.Open(FileName,UpdateLinks,ReadOnly,Format,Password,WriteResPassword,IgnoreReadOnlyRecommended,Origin,Delimiter,Editable,Notify,Converter,AddTomru,Local,CorruptLoad)
  'Help page: https://docs.microsoft.com/en-us/office/vba/api/excel.workbooks.open
  
  
' ----------------------------------------------------------------
' Procedure Name: AdvancedFilter_Columns
' Purpose: Uses Advanced Filter to copy individual columns
'
' Result: The result will be the Item and Sales column in the Report
'         worksheet.
' Website: https://excelmacromastery.com/
' ----------------------------------------------------------------
' https://excelmacromastery.com/
' Sub AdvancedFilter_Columns()

    ' Get the worksheets
    Dim shRead As Worksheet,shWrite As Worksheet,shCriteria As Worksheet
    Set shRead = wk.Worksheets("Vacancy Announcements & Flyers")
    Set shWrite = ThisWorkbook.Worksheets("Sheet1")
    Set shCriteria = ThisWorkbook.Worksheets("Criteria")
    
    ' Clear any existing data
    shWrite.Cells.Clear
    
    ' Specify the output columns
    shWrite.Range("A1").Value2 = "Org"
    shWrite.Range("B1").Value2 = "Position Title,PP/Ser/Gr"
    shWrite.Range("C1").Value2 = "Open Date"
    shWrite.Range("D1").Value2 = "Close Date"
    shWrite.Range("E1").Value2 = "Link"

    ' Remove the filter
    If shRead.FilterMode = True Then
        shRead.ShowAllData
    End If
    
      'find last row and column
    Dim lastRow As Long,lastCol As Long
    
    ' Get the last cell with data in column A
    lastRow = shRead.Cells(shRead.Rows.Count,1).End(xlUp).Row
    
    ' Get the last cell with data in row 1
    lastCol = shRead.Cells(1,shRead.Columns.Count).End(xlToLeft).Column
    
    Dim rg As Range,rgData As Range
    
With shRead
        ' Get the full range of data from A1 to last row and column
        Set rg = .Range(.Cells(1,1),.Cells(lastRow,lastCol))
    End With
     
     
     Dim rgCriteria As Range
    ' IMPORTANT: Do not have any blank rows in the criteria range
    Set rgCriteria = shCriteria.Range("A1:X3")
   
    ' Apply the filter
                
                    rg.AdvancedFilter Action:=xlFiltercopy,Criteriarange:=rgCriteria _,copyToRange:=shWrite.Range("A1")
                
                                    rg.AdvancedFilter Action:=xlFiltercopy,copyToRange:=shWrite.Range("B1")
                
                                    rg.AdvancedFilter Action:=xlFiltercopy,copyToRange:=shWrite.Range("C1")
                
                                   rg.AdvancedFilter Action:=xlFiltercopy,copyToRange:=shWrite.Range("D1")
                
                                    rg.AdvancedFilter Action:=xlFiltercopy,copyToRange:=shWrite.Range("E1")

'close workbook without saving changes
wk.Close SaveChanges:=False

End Sub

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）

advanced-filter copy copy