I have an Excel workbook with a VBA script I inherited from a co-worker. I am not a skilled VBA user, so I cannot figure out how to modify this to make it work for what I need. The script currently cycles through specific files in a location I browse to in a window that pops up and consolidates information from a range of vehicles into a summary sheet and a tab containing more data for each worksheet in each workbook. I want to add a function to count the rows with data in the range B26:B1000 and put that in row 23 of the column created based on the "Template" sheet and in column X on the "Summary" page.
Sheets in workbook with VBA:
VBA code from workbook with VBA:
Option Explicit
Option Base 1
#If Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" _
(ByRef pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserve As Long, _
ByRef lpfnCB As LongPtr) As LongPtr
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" ( _
ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
#End If
Dim targetWB As Excel.Workbook
Dim targetWS As Excel.Worksheet
Dim iRow As Integer
Private Sub CB_BrowseLocalFolder_Click()
Dim sItem As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
If sItem <> "" Then
TB_LocalFolder.Text = sItem
End If
End Sub
Private Sub CB_BrowseSharepointFolder_Click()
Dim sItem As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
If sItem <> "" Then
TB_SharepointFolder.Text = sItem
End If
End Sub
Private Sub CB_Close_Click()
Unload Me
End Sub
Private Sub CB_CreateReport_Click()
Call CreateReport
End Sub
Private Sub CB_DownloadFiles_Click()
Call DownloadFiles
End Sub
Private Sub CB_Reset_Click()
Application.ScreenUpdating = False
Call ResetReport
Application.ScreenUpdating = True
End Sub
Sub ResetReport()
Dim rng As Excel.Range
'delete target worksheets
Set targetWB = ActiveWorkbook
Application.DisplayAlerts = False
For Each targetWS In targetWB.Worksheets
Me.LB_Status.Caption = "Deleting " & targetWS.Name
Me.Repaint
If targetWS.Name <> "Template" And targetWS.Name <> "Summary" Then targetWS.Delete
Next
Application.DisplayAlerts = True
Me.LB_Status.Caption = "Reseting Summary"
Me.Repaint
'clear summary sheet
targetWB.Worksheets("Summary").Activate
Set rng = targetWB.Worksheets("Summary").Range("A2:W2")
targetWB.Worksheets("Summary").Range(rng, rng.End(xlDown)).Clear
Me.LB_Status.Caption = "Ready ..."
End Sub
Private Sub TB_LocalFolder_Change()
ActiveWorkbook.Names.Add Name:="LocalFolder", RefersTo:=TB_LocalFolder.Text
End Sub
Private Sub TB_SharepointFolder_Change()
ActiveWorkbook.Names.Add Name:="SharepointFolder", RefersTo:=TB_SharepointFolder.Text
End Sub
Private Sub UserForm_Initialize()
TB_LocalFolder.Text = Replace(Replace(ActiveWorkbook.Names("LocalFolder"), """", ""), "=", "")
TB_SharepointFolder.Text = Replace(Replace(ActiveWorkbook.Names("SharepointFolder"), """", ""), "=", "")
Me.LB_Status.Caption = "Ready ..."
End Sub
Sub CreateReport()
Dim sPathName As String
Dim sFileName As String
Dim iCount As Integer
'Summary Row
iRow = 1
'Path and File Name
sPathName = Replace(Replace(ActiveWorkbook.Names("LocalFolder"), """", ""), "=", "")
sFileName = Dir(sPathName & "\*Usage*.xl*")
Call ResetReport
Application.ScreenUpdating = False
'create report sheets
While sFileName <> ""
Me.LB_Status.Caption = "Processing " & sFileName
Me.Repaint
Call CreateSubReports(sPathName, sFileName)
sFileName = Dir()
Wend
Me.LB_Status.Caption = "Ready ..."
'summary border s
Set targetWS = targetWB.Worksheets("Summary")
With targetWS.Range(targetWS.Cells(2, 1).Address & ":" & targetWS.Cells(iRow, 23).Address)
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.BorderAround xlContinuous
End With
For iCount = 1 To 23
targetWS.Columns(iCount).AutoFit
Next
targetWB.Sheets("Template").Activate
targetWB.Sheets("Template").Range("A1").Select
targetWS.Activate
targetWS.Range("A1").Activate
Application.ScreenUpdating = True
End Sub
Sub CreateSubReports(sPathName As String, sFileName As String)
Dim sourceWB As Excel.Workbook
Dim sourceWS As Excel.Worksheet
Dim isFound As Boolean
Dim iColumn As Integer
Dim SProgramName As String
Dim targetOrder() As Variant
Dim iCount As Integer
Dim cell As Range
Dim rng As Range
isFound = False
Set sourceWB = Workbooks.Open(sPathName & "\" & sFileName, True, True)
SProgramName = Split(sFileName, " ")(0)
iColumn = 1
targetOrder = Array(2, 9, 10, 11, 12, 4, 6, 7, 8, 5, 3, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23)
For Each sourceWS In sourceWB.Worksheets
If sourceWS.Range("CY1").Value = sourceWS.Name Then
iColumn = iColumn + 1
iRow = iRow + 1
If Not isFound Then
isFound = True
targetWB.Sheets("Template").Copy after:=targetWB.Sheets(targetWB.Sheets.Count)
Set targetWS = targetWB.ActiveSheet
targetWS.Name = SProgramName
End If
targetWB.Worksheets("Summary").Range(targetWB.Worksheets("Summary").Cells(iRow, 1).Address).Value = SProgramName
sourceWS.Range("CY1:CY22").Copy
targetWS.Range(targetWS.Cells(1, iColumn).Address & ":" & targetWS.Cells(22, iColumn).Address).PasteSpecial xlPasteValues
For iCount = 1 To 22
targetWB.Worksheets("Summary").Range(targetWB.Worksheets("Summary").Cells(iRow, targetOrder(iCount)).Address).Value = _
WorksheetFunction.Trim(sourceWS.Range("CY" & iCount))
targetWB.Worksheets("Template").Cells(iCount, 2).Copy
targetWB.Worksheets("Summary").Range(targetWB.Worksheets("Summary").Cells(iRow, targetOrder(iCount)).Address).PasteSpecial xlPasteFormats
Next
sourceWS.Range("BJ26:BJ500").Copy
targetWS.Range(targetWS.Cells(30, iColumn).Address & ":" & targetWS.Cells(504, iColumn).Address).PasteSpecial xlPasteValuesAndNumberFormats
'format column
targetWB.Worksheets("Template").Range("B1:B504").Copy
targetWS.Range(targetWS.Cells(1, iColumn).Address & ":" & targetWS.Cells(504, iColumn).Address).PasteSpecial xlPasteFormats
Set rng = Nothing
For Each cell In targetWS.Range(targetWS.Cells(30, iColumn).Address & ":" & targetWS.Cells(504, iColumn).Address)
If cell.Value = "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Application.Union(rng, cell)
End If
End If
Next
If Not rng Is Nothing Then rng.Delete Shift:=xlUp
targetWS.Columns(iColumn).AutoFit
targetWS.Range("A1").Activate
End If
Next
targetWS.Range("B29:" & targetWS.Cells(29, iColumn).Address).Merge
targetWS.Range("B29:" & targetWS.Cells(29, iColumn).Address).HorizontalAlignment = xlCenter
targetWS.Range("B29:" & targetWS.Cells(29, iColumn).Address).BorderAround (xlContinuous)
Application.DisplayAlerts = False
sourceWB.Close
Application.DisplayAlerts = True
End Sub
Public Sub DownloadFiles()
Dim sSharepointFolder As String
Dim sLocalFolder As String
Dim fso As FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
Dim folder As folder
Dim file As file
sSharepointFolder = Replace(Replace(Replace(ActiveWorkbook.Names("SharepointFolder"), """", ""), "=", ""), " ", "%20")
If Right(sSharepointFolder, 1) <> "/" Then sSharepointFolder = sSharepointFolder & "/"
sLocalFolder = Replace(Replace(ActiveWorkbook.Names("LocalFolder"), """", ""), "=", "")
If Right(sLocalFolder, 1) <> "/" Then sLocalFolder = sLocalFolder & "\"
Set folder = fso.GetFolder(Replace(Replace(Replace(sSharepointFolder, "https:", ""), "http:", ""), "/", "\"))
For Each file In folder.Files
' If InStr(file.Name, "Fuel Usage.xlsx") <> 0 Then
Me.LB_Status.Caption = "Downloading " & file.Name
Me.Repaint
Call URLDownloadToFile(0, sSharepointFolder & file.Name, sLocalFolder & file.Name, 0, 0)
' End If
Next file
Me.LB_Status.Caption = "Ready ..."
End Sub
Sheets from workbook with sample data:
What I need is add a section to the VBA to count rows/cells with data in the range B25:B1000 and put that count in the appropriate places in the final workbook that is created as this loops through the files I am using. Any help will be appreciated!
Thank you.
Sheets in workbook with VBA:
| Summary.xlsm | |||
|---|---|---|---|
| A | |||
| 1 | Program | ||
Summary | |||
| Summary.xlsm | |||
|---|---|---|---|
| E | |||
| 25 | |||
Template | |||
VBA code from workbook with VBA:
Option Explicit
Option Base 1
#If Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" _
(ByRef pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserve As Long, _
ByRef lpfnCB As LongPtr) As LongPtr
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" ( _
ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
#End If
Dim targetWB As Excel.Workbook
Dim targetWS As Excel.Worksheet
Dim iRow As Integer
Private Sub CB_BrowseLocalFolder_Click()
Dim sItem As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
If sItem <> "" Then
TB_LocalFolder.Text = sItem
End If
End Sub
Private Sub CB_BrowseSharepointFolder_Click()
Dim sItem As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
If sItem <> "" Then
TB_SharepointFolder.Text = sItem
End If
End Sub
Private Sub CB_Close_Click()
Unload Me
End Sub
Private Sub CB_CreateReport_Click()
Call CreateReport
End Sub
Private Sub CB_DownloadFiles_Click()
Call DownloadFiles
End Sub
Private Sub CB_Reset_Click()
Application.ScreenUpdating = False
Call ResetReport
Application.ScreenUpdating = True
End Sub
Sub ResetReport()
Dim rng As Excel.Range
'delete target worksheets
Set targetWB = ActiveWorkbook
Application.DisplayAlerts = False
For Each targetWS In targetWB.Worksheets
Me.LB_Status.Caption = "Deleting " & targetWS.Name
Me.Repaint
If targetWS.Name <> "Template" And targetWS.Name <> "Summary" Then targetWS.Delete
Next
Application.DisplayAlerts = True
Me.LB_Status.Caption = "Reseting Summary"
Me.Repaint
'clear summary sheet
targetWB.Worksheets("Summary").Activate
Set rng = targetWB.Worksheets("Summary").Range("A2:W2")
targetWB.Worksheets("Summary").Range(rng, rng.End(xlDown)).Clear
Me.LB_Status.Caption = "Ready ..."
End Sub
Private Sub TB_LocalFolder_Change()
ActiveWorkbook.Names.Add Name:="LocalFolder", RefersTo:=TB_LocalFolder.Text
End Sub
Private Sub TB_SharepointFolder_Change()
ActiveWorkbook.Names.Add Name:="SharepointFolder", RefersTo:=TB_SharepointFolder.Text
End Sub
Private Sub UserForm_Initialize()
TB_LocalFolder.Text = Replace(Replace(ActiveWorkbook.Names("LocalFolder"), """", ""), "=", "")
TB_SharepointFolder.Text = Replace(Replace(ActiveWorkbook.Names("SharepointFolder"), """", ""), "=", "")
Me.LB_Status.Caption = "Ready ..."
End Sub
Sub CreateReport()
Dim sPathName As String
Dim sFileName As String
Dim iCount As Integer
'Summary Row
iRow = 1
'Path and File Name
sPathName = Replace(Replace(ActiveWorkbook.Names("LocalFolder"), """", ""), "=", "")
sFileName = Dir(sPathName & "\*Usage*.xl*")
Call ResetReport
Application.ScreenUpdating = False
'create report sheets
While sFileName <> ""
Me.LB_Status.Caption = "Processing " & sFileName
Me.Repaint
Call CreateSubReports(sPathName, sFileName)
sFileName = Dir()
Wend
Me.LB_Status.Caption = "Ready ..."
'summary border s
Set targetWS = targetWB.Worksheets("Summary")
With targetWS.Range(targetWS.Cells(2, 1).Address & ":" & targetWS.Cells(iRow, 23).Address)
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.BorderAround xlContinuous
End With
For iCount = 1 To 23
targetWS.Columns(iCount).AutoFit
Next
targetWB.Sheets("Template").Activate
targetWB.Sheets("Template").Range("A1").Select
targetWS.Activate
targetWS.Range("A1").Activate
Application.ScreenUpdating = True
End Sub
Sub CreateSubReports(sPathName As String, sFileName As String)
Dim sourceWB As Excel.Workbook
Dim sourceWS As Excel.Worksheet
Dim isFound As Boolean
Dim iColumn As Integer
Dim SProgramName As String
Dim targetOrder() As Variant
Dim iCount As Integer
Dim cell As Range
Dim rng As Range
isFound = False
Set sourceWB = Workbooks.Open(sPathName & "\" & sFileName, True, True)
SProgramName = Split(sFileName, " ")(0)
iColumn = 1
targetOrder = Array(2, 9, 10, 11, 12, 4, 6, 7, 8, 5, 3, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23)
For Each sourceWS In sourceWB.Worksheets
If sourceWS.Range("CY1").Value = sourceWS.Name Then
iColumn = iColumn + 1
iRow = iRow + 1
If Not isFound Then
isFound = True
targetWB.Sheets("Template").Copy after:=targetWB.Sheets(targetWB.Sheets.Count)
Set targetWS = targetWB.ActiveSheet
targetWS.Name = SProgramName
End If
targetWB.Worksheets("Summary").Range(targetWB.Worksheets("Summary").Cells(iRow, 1).Address).Value = SProgramName
sourceWS.Range("CY1:CY22").Copy
targetWS.Range(targetWS.Cells(1, iColumn).Address & ":" & targetWS.Cells(22, iColumn).Address).PasteSpecial xlPasteValues
For iCount = 1 To 22
targetWB.Worksheets("Summary").Range(targetWB.Worksheets("Summary").Cells(iRow, targetOrder(iCount)).Address).Value = _
WorksheetFunction.Trim(sourceWS.Range("CY" & iCount))
targetWB.Worksheets("Template").Cells(iCount, 2).Copy
targetWB.Worksheets("Summary").Range(targetWB.Worksheets("Summary").Cells(iRow, targetOrder(iCount)).Address).PasteSpecial xlPasteFormats
Next
sourceWS.Range("BJ26:BJ500").Copy
targetWS.Range(targetWS.Cells(30, iColumn).Address & ":" & targetWS.Cells(504, iColumn).Address).PasteSpecial xlPasteValuesAndNumberFormats
'format column
targetWB.Worksheets("Template").Range("B1:B504").Copy
targetWS.Range(targetWS.Cells(1, iColumn).Address & ":" & targetWS.Cells(504, iColumn).Address).PasteSpecial xlPasteFormats
Set rng = Nothing
For Each cell In targetWS.Range(targetWS.Cells(30, iColumn).Address & ":" & targetWS.Cells(504, iColumn).Address)
If cell.Value = "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Application.Union(rng, cell)
End If
End If
Next
If Not rng Is Nothing Then rng.Delete Shift:=xlUp
targetWS.Columns(iColumn).AutoFit
targetWS.Range("A1").Activate
End If
Next
targetWS.Range("B29:" & targetWS.Cells(29, iColumn).Address).Merge
targetWS.Range("B29:" & targetWS.Cells(29, iColumn).Address).HorizontalAlignment = xlCenter
targetWS.Range("B29:" & targetWS.Cells(29, iColumn).Address).BorderAround (xlContinuous)
Application.DisplayAlerts = False
sourceWB.Close
Application.DisplayAlerts = True
End Sub
Public Sub DownloadFiles()
Dim sSharepointFolder As String
Dim sLocalFolder As String
Dim fso As FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
Dim folder As folder
Dim file As file
sSharepointFolder = Replace(Replace(Replace(ActiveWorkbook.Names("SharepointFolder"), """", ""), "=", ""), " ", "%20")
If Right(sSharepointFolder, 1) <> "/" Then sSharepointFolder = sSharepointFolder & "/"
sLocalFolder = Replace(Replace(ActiveWorkbook.Names("LocalFolder"), """", ""), "=", "")
If Right(sLocalFolder, 1) <> "/" Then sLocalFolder = sLocalFolder & "\"
Set folder = fso.GetFolder(Replace(Replace(Replace(sSharepointFolder, "https:", ""), "http:", ""), "/", "\"))
For Each file In folder.Files
' If InStr(file.Name, "Fuel Usage.xlsx") <> 0 Then
Me.LB_Status.Caption = "Downloading " & file.Name
Me.Repaint
Call URLDownloadToFile(0, sSharepointFolder & file.Name, sLocalFolder & file.Name, 0, 0)
' End If
Next file
Me.LB_Status.Caption = "Ready ..."
End Sub
Sheets from workbook with sample data:
| sample fuel usage.xlsx | |||
|---|---|---|---|
| G | |||
| 13 | |||
ID00006 | |||
| sample fuel usage.xlsx | |||
|---|---|---|---|
| G | |||
| 13 | |||
ID00007 | |||
What I need is add a section to the VBA to count rows/cells with data in the range B25:B1000 and put that count in the appropriate places in the final workbook that is created as this loops through the files I am using. Any help will be appreciated!
Thank you.
