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.
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.
VBA 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