Consolidation Macro to run with command button

wells

New Member
Joined
Jan 9, 2020
Messages
24
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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.

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
 

Some videos you may like

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

Watch MrExcel Video

Forum statistics

Threads
1,118,210
Messages
5,570,918
Members
412,349
Latest member
big_words
Top