Im new to VBA and I have been trying to create a program to copy specific range from multiple workbooks having data in sheet 2 to a master workbook sheet 2 .
COPY Condition: the column range will be A20 to AS20 while the row range will depend upon the last cell having data in column R.
PASTE Condition: consecutively all copied cells should be pasted with one blank row in between starting from row A20
COPY paste condition: range D5 : D18 from source books to the master sheet, on a overlapping manner since the range will be same in all source books.
I came till the below stage, but no idea to proceed further. Made some corrections but didnt work well.
Prog:
Sub copyDataFromMultipleWorkbooksIntoMaster()
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim BrowseFolder As String
Dim masterBook As Workbook
Dim sourceBook As Workbook
Dim insertRow As Long
Dim copyRow As Long
insertRow = 20
Set masterBook = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder with source files"
If Not .Show = 0 Then
BrowseFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
Application.ScreenUpdating = False
Set oFolder = FSO.getfolder(BrowseFolder)
masterBook.Sheets("Service Order Template").Cells.UnMerge
For Each FileItem In oFolder.Files
If FileItem.Name Like "*.xls*" Then
Workbooks.Open (BrowseFolder & Application.PathSeparator & FileItem.Name)
Set sourceBook = Workbooks(FileItem.Name)
With sourceBook.Sheets("Service Order Template")
.Cells.UnMerge
copyRow = .Cells(Rows.Count, 18).End(xlUp).Row
Range(.Cells(20, 1), .Cells(copyRow, 45)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(insertRow, 1)
Application.CutCopyMode = False
.Parent.Close SaveChanges:=False
End With
insertRow = masterBook.Sheets("Service Order Template").Cells(Rows.Count, 18).End(xlUp).Row + 2
End If
Next
Application.ScreenUpdating = True
End Sub
check this. See comments in code, if questions - put comments to answer. Hope you find something new. You have to put this code to the Module in Master workbook.
Sub copyDataFromMultipleWorkbooksIntoMaster()
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim BrowseFolder As String
Dim masterBook As Workbook
Dim sourceBook As Workbook
Dim insertRow As Long
Dim copyRow As Long
' add variables for blank check
Dim checkRange As Range, r As Range
insertRow = 20
Set masterBook = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder with source files"
If Not .Show = 0 Then
BrowseFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
Application.ScreenUpdating = False
Set oFolder = FSO.getfolder(BrowseFolder)
masterBook.Sheets("Service Order Template").Cells.UnMerge
For Each FileItem In oFolder.Files
If FileItem.Name Like "*.xls*" Then
Workbooks.Open (BrowseFolder & Application.PathSeparator & FileItem.Name)
Set sourceBook = Workbooks(FileItem.Name)
With sourceBook.Sheets("Service Order Template")
.Cells.UnMerge
copyRow = .Cells(Rows.Count, 18).End(xlUp).Row
Range(.Cells(20, 1), .Cells(copyRow, 45)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(insertRow, 1)
' copy additional needed range D5 : D18 from source to range D5 on master
Range(.Cells(5, 4), .Cells(18, 4)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(5, 4)
Application.CutCopyMode = False
.Parent.Close SaveChanges:=False
End With
masterBook.Sheets("Service Order Template").insertRow = .Cells(Rows.Count, 18).End(xlUp).Row + 2
End If
Next
With masterBook.Sheets("Service Order Template")
' if you don't need to highlight the whole row - remove the ".EntireRow" part →---→---→----↓
Range(.Cells(20, 18), .Cells(Rows.Count, 18).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Interior.Color = vbYellow
End With
Application.ScreenUpdating = True
End Sub