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
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

Forum statistics

Threads
1,212,933
Messages
6,110,752
Members
448,295
Latest member
Uzair Tahir Khan

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top