VBA将多个已关闭的工作表导入中央工作表 - 只显示一个文件的数据?

内容来源于 Stack Overflow,并遵循CC BY-SA 3.0许可协议进行翻译与使用

  • 回答 (1)
  • 关注 (0)
  • 查看 (100)

我试图创建一个集中的数据库,将多个工作簿中的相同选项卡(名为“导入”)导入到不同工作簿中的选项卡上。

当我运行代码时,只有来自一个文件(打开的文件)的数据被导入到数据库工作表中,并且我希望所有选定文件的“导入”选项卡都被引入。另外,我想不要打开任何源文件以导入其数据。

    Sub InsertDatabase()

Dim FileNames As Variant 'Group of files to be looped through
Dim FileName As Variant 'Country of focus (file open)
Dim ActiveCountryWB As Workbook 'Active workbook of country
Dim wksSrcCountry As Worksheet 'Import worksheet in country
Dim wksDstDatabase As Worksheet 'Data worksheet in database
Dim rngSrcCountry As Range 'Range of data in import worksheet
Dim rngDstDatabase As Range 'Range of data in data worksheet in database
Dim lngSrcLastRow As Long
Dim lngDstLastRow As Long

'Set destination reference
Set wksDstDatabase = ThisWorkbook.Worksheets(1)

MsgBox "In the following browser, please choose the Excel file(s) you want to copy data from"
FileNames = Application.GetOpenFilename _
(Title:="Please choose the files you want to copy data FROM", _
FileFilter:="All Files (*.*),*.*", _
MultiSelect:=True)

If VarType(CountriesGroup) = vbBoolean Then
If Not CountriesGroup Then Exit Sub
End If

'Set initial destination range
lngDstLastRow = LastOccupiedRowNum(wksDstDatabase)
Set rngDstDatabase = wksDstDatabase.Cells(lngDstLastRow + 1, 1)

'Loop over all files selected by user, and import the desired "Import" sheet
For Each FileName In FileNames

'Set country workbook references
Set ActiveCountryWB = Workbooks.Open(FileName)
Set wksSrcCountry = ActiveCountryWB.Sheets("Import")

    'Identify last occupied row on import sheet
    lngSrcLastRow = LastOccupiedRowNum(wksSrcCountry)

    'Store source data
    With wksSrcCountry
        Set rngSrcCountry = .Range(.Cells(1, 1), .Cells(lngSrcLastRow, 20))
        rngSrcCountry.Copy Destination:=rngDstDatabase
    End With

    'Redefine destination range now that new data has been added
    lngDstLastRow = LastOccupiedRowNum(wksDstDatabase)
    Set rngDstDatabase = wksDstDatabase.Cells(lngDstLawRow + 1, 1)

Next FileName

End Sub

Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long

    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet

        lng = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    LastOccupiedRowNum = lng
End Function
提问于
用户回答回答于

你不需要一个函数来确定最后一行(如下所示)。我会试试这个(把你的代码清除出excel)。宏应该遵循以下步骤:

1)提示用户选择导入文件 2)将数据表格“导入”工作表从Col A-T(下降到最后一行)复制到数据库中 3)关闭导入书籍 4)循环步骤2和3,直到所有导入书籍都是覆盖

- 将此代码粘贴到模块中 - 创建一个名为“数据”的新工作表(确保它包含标题或将错误输出) - 如果你的导入工作表包含标题,则需要将副本范围从A1更改为A2(否则,你将继续在数据中间导入标题)

Sub Database()

Dim CurrentBook As Workbook 'Import books
Dim ImportFiles As FileDialog
Dim FileCount As Long 'Count of Import books selected
Dim Database As Worksheet
    Set Database = ThisWorkbook.Sheets("Data")

'Open File Picker
Set ImportFiles = Application.FileDialog(msoFileDialogOpen)
With ImportFiles
    .AllowMultiSelect = True
    .Title = "Pick import files"
    .ButtonName = ""
    .Filters.Clear
    .Filters.Add ".xlsx files", "*.xlsx"
    .Show
End With

'Stop Alerts/Screen Updating
Application.DisplayAlerts = False
Application.DisplayAlerts = False

'Move Data from ImportBook(s) to Database
For FileCount = 1 To ImportFiles.SelectedItems.Count
    Set CurrentBook = Workbooks.Open(ImportFiles.SelectedItems(FileCount))

    'Determine Last Row on Import Book
    Dim ImportLRow As Long
    ImportLRow = CurrentBook.Sheets("Import").Range("A" & CurrentBook.Sheets("Import").Rows.Count).End(xlUp).Row

    'Determine Last Row on Database Book
    Dim DatabaseLRow As Long
    DatabaseLRow = Database.Range("A" & Database.Rows.Count).End(xlUp).Offset(1).Row

    'Copy Range
    Dim CopyRange As Range
    Set CopyRange = CurrentBook.Sheets("Import").Range("A1:T" & ImportLRow) 'If the sheets have headers, change this from A1 to A2
        CopyRange.Copy

    'Paste Range
    Database.Range("A" & DatabaseLRow).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone

    'Close Import Book (Do not save)
    CurrentBook.Close False

Next FileIdx

'Enable Alerts/Screen Updating
Application.DisplayAlerts = True
Application.DisplayAlerts = True

End Sub

扫码关注云+社区

领取腾讯云代金券