Looking to Loop Excel VBA Macro through Multiple Worksheets? - vba

Question

Looking to loop the following code through (about) 125 worksheets in an Excel workbook and pull the listed cell values into one database entry log on the 'Database' worksheet'. Right now it is only pulling from one of the tabs . (PO VT-0189). Wondering how to correct.
Private Sub PopulateOrderInfo()
Dim OrderDate As String, PONumber As String, Vendor As String, ShipTo As String, SKU As String
Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet
For Each OFrm In ActiveWorkbook.Worksheets
Set OFrm = Worksheets("PO VT-0189")
Set DB = Worksheets("Database")
OrderDate = OFrm.Range("N4")
PONumber = OFrm.Range("N3")
Vendor = OFrm.Range("A13")
ShipTo = OFrm.Range("I13")
POTotal = OFrm.Range("P43")
LastSKURow = OFrm.Range("A38").End(xlUp).Row
For R = 21 To LastSKURow
SKU = OFrm.Range("A" & R).Value
SKUDesc = OFrm.Range("D" & R).Value
SKUQty = OFrm.Range("K" & R).Value
Lntotal = OFrm.Range("M" & R).Value
NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1
DB.Range("A" & NextDBRow).Value = OrderDate
DB.Range("B" & NextDBRow).Value = PONumber
DB.Range("C" & NextDBRow).Value = Vendor
DB.Range("D" & NextDBRow).Value = ShipTo
DB.Range("E" & NextDBRow).Value = SKU
DB.Range("F" & NextDBRow).Value = SKUDesc
DB.Range("G" & NextDBRow).Value = SKUQty
DB.Range("H" & NextDBRow).Value = Lntotal
DB.Range("I" & NextDBRow).Value = POTotal
Next R
Next OFrm
End Sub

Answer 1

I think you can also shorten your code by avoiding the loop and most of the variables seem unnecessary to me.
Private Sub PopulateOrderInfo()
Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet
Set DB = Worksheets("Database")
For Each OFrm In ActiveWorkbook.Worksheets
If OFrm.Name <> DB.Name Then
LastSKURow = OFrm.Range("A38").End(xlUp).Row
R = LastSKURow - 21 + 1
NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1
DB.Range("A" & NextDBRow).Resize(R).Value = OFrm.Range("N4")
DB.Range("B" & NextDBRow).Resize(R).Value = OFrm.Range("N3")
DB.Range("C" & NextDBRow).Resize(R).Value = OFrm.Range("A13")
DB.Range("D" & NextDBRow).Resize(R).Value = OFrm.Range("I13")
DB.Range("E" & NextDBRow).Resize(R).Value = OFrm.Range("A21").Resize(R).Value
DB.Range("F" & NextDBRow).Resize(R).Value = OFrm.Range("D21").Resize(R).Value
DB.Range("G" & NextDBRow).Resize(R).Value = OFrm.Range("K21").Resize(R).Value
DB.Range("H" & NextDBRow).Resize(R).Value = OFrm.Range("M21").Resize(R).Value
DB.Range("I" & NextDBRow).Resize(R).Value = OFrm.Range("P43")
End If
Next OFrm
End Sub

Answer 2

Use a for loop and WorkSheets collection like:
For I = 1 to worksheets.count
if worksheets(i).name <> "Database" then
Add your code here
end if
Next i
This loops through every worksheet in your workbook and does what ever you need to all worksheets except the Database.

Answer 3

Using a for each... loop
For Each ws In wb.Worksheets
If ws.name = "Database" Then
'Leave blank to just skip database. Code here if you want something special on database. OR statements can be used to exclude additional sheets
Else
'Code here
End If
Next

Answer 4

I think you described the issue fairly well. Just to confirm, you want to loop through all worksheets in one single workbook, right. Try the script below. Feedback if you have additional questions, concerns, etc. Thanks.
Sub ImportAll()
Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
Dim lngCount As Long
Dim objExcel As Object, objWorkbook As Object
Dim colWorksheets As Collection
Dim strPathFile as String, strTable as String
Dim strPassword As String
' Establish an EXCEL application object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set objExcel = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = False
' Replace C:\Filename.xls with the actual path and filename
strPathFile = "C:\Filename.xls"
' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "tablename"
' Replace passwordtext with the real password;
' if there is no password, replace it with vbNullString constant
' (e.g., strPassword = vbNullString)
strPassword = "passwordtext"
blnReadOnly = True ' open EXCEL file in read-only mode
' Open the EXCEL file and read the worksheet names into a collection
Set colWorksheets = New Collection
Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , _
strPassword)
For lngCount = 1 To objWorkbook.Worksheets.Count
colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
Next lngCount
' Close the EXCEL file without saving the file, and clean up the EXCEL objects
objWorkbook.Close False
Set objWorkbook = Nothing
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing
' Import the data from each worksheet into the table
For lngCount = colWorksheets.Count To 1 Step -1
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$"
Next lngCount
' Delete the collection
Set colWorksheets = Nothing
' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile
End Sub