我正在尝试创建一个集中式数据库,将多个工作簿中相同的选项卡(名为"Import")导入到不同工作簿上的某个选项卡中。
我是VBA的新手,正在修改来自VBA Import multiple sheets into Workbook和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
发布于 2018-06-02 05:46:23
你在网上提取的代码实在是拼凑得很糟糕。您不需要函数来确定最后一行(如下所示)。我会尝试这样做(将您的代码从excel中清除)。宏应遵循以下步骤:
1)提示用户选择导入文件
2)将数据表单"Import“工作表从A-T列(向下复制到最后一行)复制到数据库中
3)关闭导入手册
4)循环步骤2和3,直到涵盖了所有导入书籍
在一个模块中-Paste这段代码
创建一个名为“-Create”的新工作表(确保它有标题,否则会出错)
-If您的导入工作表具有标题,您需要将复制范围从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
https://stackoverflow.com/questions/50650660
复制相似问题