Hey Folks...!!
I have a VBA Script that will copy multiple file data from a folder to a Template that is pre loaded in the same file. My requirements is
1. I want to add some command button and move the template to somewhere hidden. ( Its ok if a folder has to be maintained).
2. At the end I dont want my macro file to close since I need to continue working with same Macro file.
Please tell me a possible idea... My code is as below.
Code
- Option Explicit
- Sub CopyDataFromMultipleWorkbooks()
- Const TEMPLATE = "Service Order Template"
- Const SITE_TEMPLATE = "Site Creation Template(Project)"
- Dim FSO As Object
- Dim BrowseFolder As String
- Dim oFolder As Object
- ' select folder
- 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
- MsgBox "Cancelled selection", vbCritical
- Exit Sub
- End If
- End With
- 'Debug.Print "BrowseFolder = " & BrowseFolder
- Application.DisplayAlerts = False
- Application.ScreenUpdating = False
- Dim wbMaster As Workbook, wsMaster As Worksheet
- Dim wbSource As Workbook, wsSource As Worksheet, wrSource As Worksheet, rngSource As Range
- Dim f As Object, fname As String
- Dim lastSrcRow As Long
- Dim insertRow1 As Long, insertRow2 As Long, count As Long
- Dim lrow As Long
- Set wbMaster = ThisWorkbook
- Set wsMaster = wbMaster.Sheets(TEMPLATE)
- insertRow1 = 22
- insertRow2 = 10 ' start of row 10 copies on sheet 2 of master
- Set oFolder = FSO.GetFolder(BrowseFolder)
- count = 0
- ' scan files
- For Each f In oFolder.Files
- If f.Name Like "*.xls*" Then
- fname = BrowseFolder & Application.PathSeparator & f.Name
- 'Debug.Print fname
- Set wbSource = Workbooks.Open(fname, False, True) ' open no link update, read-only
- Set wsSource = wbSource.Sheets(TEMPLATE)
- lastSrcRow = wsSource.Cells(Rows.count, 18).End(xlUp).Row
- Set rngSource = wsSource.Range("A22:AS" & lastSrcRow) ' AS=col45
- Debug.Print f.Name, wsSource.Name, rngSource.Address
- rngSource.Copy wsMaster.Cells(insertRow1, 1)
- insertRow1 = insertRow1 + rngSource.Rows.count
- ' copy additional needed range D5 : D18 from source to range D5 on master
- wsSource.Range("D5:D18").Copy wsMaster.Range("D5")
- Dim VSource As Range
- Set wrSource = wbSource.Sheets(SITE_TEMPLATE)
- lrow = wrSource.Cells(Rows.count, "N").End(xlUp).Row
- Set VSource = wrSource.Range("A10:Z" & lrow)
- 'copying row 10 from sheet 2 with name "Site Creation Template(Project)"
- wbSource.Sheets(SITE_TEMPLATE).Rows(10 & ":" & lrow).Copy wbMaster.Sheets(SITE_TEMPLATE).Range("A" & insertRow2)
- insertRow2 = insertRow2 + VSource.Rows.count
- wbSource.Close False
- count = count + 1
- End If
- Next
- ' if you don't need to highlight the whole row - remove the ".EntireRow" part ?---?---?----?
- wsMaster.Range("M20:M" & insertRow1 - 1).SpecialCells(xlCellTypeBlanks).EntireRow.Interior.Color = vbYellow
- wsMaster.Cells.Select
- With Selection
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlBottom
- .Orientation = 0
- .AddIndent = False
- .IndentLevel = 0
- .ReadingOrder = xlContext
- End With
- With Selection
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- .Orientation = 0
- .AddIndent = False
- .IndentLevel = 0
- .ReadingOrder = xlContext
- End With
- Selection.EntireColumn.Hidden = False
- Selection.Columns.AutoFit
- wsMaster.Range("A1").Select
- ' Check next cell in range
- Next rrcell
- Dim filename As String
- Dim SeriesValue As String
- SeriesValue = InputBox("computer network", "Enter Series number")
- filename = "_" & SeriesValue & "_COT " & count & " SPOs(SO-SVO-PO) with PDF copy_CPO " & Range("D8")
- ActiveWorkbook.SaveAs filename:=Format(Date, "yyyymmdd") & filename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- MsgBox count & " Order Entry Templates processed", , " computer network "
- End Sub