Question

我正在尝试创建一个集中式数据库，将多个工作簿中的相同选项卡（名为“Import”）导入到不同工作簿上的选项卡中。我是VBA的新用户，并从此处修改其他人的代码VBA将多个工作表导入工作簿并在此处https://danwagner.co/how-to-combine-data-from-multiple-sheets-into-a-single-sheet/。

当我运行代码时，只有来自一个文件（打开文件）的数据被导入到数据库工作表中，我希望所有选定文件的“导入”选项卡都被引入。另外，我想要无需打开任何源文件即可导入其数据。

提前感谢您的帮助！

    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

Answer 1

你在线提取的代码实际上很糟糕。您不需要函数来确定最后一行（如下所示）。我会尝试这样做（从excel中清除你的代码）。该宏应遵循以下步骤：

1）提示用户选择导入文件
2）复制数据表格＆＃34;导入＆＃34;从Col A - T（到最后一行）到您的数据库的工作表
3）关闭导入书
4）循环步骤2＆amp; 3直到涵盖所有导入书籍

- 在模块中使用此代码 - 创建一个名为＆＃34; Data＆＃34; （确保它有标题或这会出错）
- 如果您的导入工作表有标题，您需要将复制范围从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

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

1 个答案: