[英]Import Multiple Spredsheets into 1 - Excel VBA
So I am new to all things VBA and have created some very basic Macros. 因此,我对VBA都是陌生的,并且创建了一些非常基本的宏。 This one I need help with.
这是我需要帮助的。
My current work has a situation where processors will have their own file, and data in column A and B only, and each new date is a new tab. 我当前的工作是处理器将拥有自己的文件,并且数据仅在A和B列中,并且每个新日期都是一个新选项卡。
I need to create a master file that pulls in all the data on the previous days tab from each individual (stored in their own folders). 我需要创建一个主文件,该文件从每个人(存储在自己的文件夹中)中提取前几天选项卡上的所有数据。 During the import I simply need to add the data to A and B on the Master sheet at the next available cell each time (To prevent blanks)
导入期间,我只需要每次在下一个可用单元格中将数据添加到“主”表上的A和B(以防止出现空白)
Is this do able? 这样可以吗?
I wrote the following that allows a user to open each file and select the range to be imported and then it does the import, but I need it all automated and driven by the date on the tab. 我编写了以下内容,允许用户打开每个文件并选择要导入的范围,然后执行导入,但是我需要将其全部自动化并由选项卡上的日期来驱动。
Also the file names are the same for each worker, nested in a folder with their name. 每个工人的文件名也相同,并以其名称嵌套在文件夹中。 The file name changes with the month.
文件名随月份变化。
Sub ClickToImport()
Dim xWb As Workbook
Dim xAddWb As Workbook
Dim xRng1 As Range
Dim xRng2 As Range
Set xWb = Application.ActiveWorkbook
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
Application.Workbooks.Open .SelectedItems(1)
Set xAddWb = Application.ActiveWorkbook
Set xRng1 = Application.InputBox(prompt:="Select source range", Title:=xTitleId, Default:="A1", Type:=8)
xWb.Activate
'Set xRng2 = Application.InputBox(prompt:="Select destination cell", Title:=xTitleId, Default:="A1", Type:=8)
Set xRng2 = Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
xRng1.Copy xRng2
xRng2.CurrentRegion.EntireColumn.AutoFit
xAddWb.Close False
End If
End With
End Sub
'I defined the next blank row in order to add the rows of data into the Master Sheet.
'Please see below
Sub ClickToImport()
Dim xWb As Workbook
Dim xAddWb As Workbook
Dim xRng1 As Range
Dim xRng2 As Range
Dim NextBlankRow As Long
NextBlankRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row + 1
Set xWb = Application.ActiveWorkbook
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
.AllowMultiSelect = False
.Title = "Choose Your File"
.Show
If .SelectedItems.Count > 0 Then
Application.Workbooks.Open .SelectedItems(1)
Set xAddWb = Application.ActiveWorkbook
Set xRng1 = Application.InputBox(prompt:="Select source range", Type:=8)
xWb.Activate
Set xRng2 = Range("A" & NextBlankRow)
xRng1.Copy xRng2
xRng2.CurrentRegion.EntireColumn.AutoFit
xAddWb.Close False
End If
End With
End Sub
You want to merge data from all sheets into one single master sheet, right. 您想将所有工作表中的数据合并到一个主表中。
'Fill in the range that you want to copy Set CopyRng = sh.Range("A1:G1") '在您要复制的范围内填充Set CopyRng = sh.Range(“ A1:G1”)
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:G1")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
As an aside, you can try the AddIn from the URL below. 顺便说一句,您可以尝试从下面的URL加载。
https://www.rondebruin.nl/win/addins/rdbmerge.htm https://www.rondebruin.nl/win/addins/rdbmerge.htm
I think you want something like this. 我想你想要这样的东西。
Sub TryThis()
Dim rng As Range, cell As Range
Set rng = Range("A1:A3")
For Each cell In rng
cell.Select
s = cell.Value
strFile = Dir(s & "*.xlsx")
Set wkb = ThisWorkbook
Set wkbFrom = Workbooks.Open(s & strFile)
Next cell
End Sub
My worksheet setup is like this. 我的工作表设置是这样的。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.