'Error 91 with loop identifying row with specific text
I am having issues with an error 91. My code is a loop and is supposed to:
- Go into every file listed in Column A and open it
- Find a particular text ("Nights") in column B on each file opened
- Copy the monthly values for the row listed as "Nights"
- Paste them onto the target sheet
The code is hitting the error once I declare my row - exactly at "DataRow = FindDataRow.Row". This statement is in the loop. Can somebody please help me?
Sub GetForecastData()
Dim Receiver As Workbook
Dim myfolder As String
Dim myfile As String
Dim oFile As Object
Dim OpenFile As Workbook
Dim FileCopy As Worksheet
Dim FilePaste As Worksheet
Dim FileRange As Range
Dim LastRow As Integer
Dim Figure As String
Dim FindDataRow As Range
Dim DataRow As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
Set Receiver = Workbooks("ForecastOccupancyMacro.xlsm")
Set FilePaste = Receiver.Worksheets("File List")
LastRow = Range("A1").End(xlDown).Row
Set FileRange = FilePaste.Range("A2:A" & LastRow)
myfolder = FilePaste.Range("A1").Value
FilePaste.Range("B2:M50").Clear
For Each oFile In FileRange
myfile = Dir(myfolder & "\" & oFile.Value)
Set OpenFile = Workbooks.Open(myfolder & "\" & oFile.Value)
Set FindDataRow = OpenFile.Worksheets("2022 Monthly Forecast").Range("B:B").Find(What:="Nights", LookIn:=xlValues, LookAt:=xlWhole)
DataRow = FindDataRow.Row
MsgBox FindDataRow.Row
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("D59").Value
oFile.Offset(0, 1) = Figure
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("N59").Value
oFile.Offset(0, 2) = Figure
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("X59").Value
oFile.Offset(0, 3) = Figure
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("AH59").Value
oFile.Offset(0, 4) = Figure
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("AR59").Value
oFile.Offset(0, 5) = Figure
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("BB59").Value
oFile.Offset(0, 6) = Figure
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("BL59").Value
oFile.Offset(0, 7) = Figure
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("BV59").Value
oFile.Offset(0, 8) = Figure
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("CF59").Value
oFile.Offset(0, 9) = Figure
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("CP59").Value
oFile.Offset(0, 10) = Figure
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("CZ59").Value
oFile.Offset(0, 11) = Figure
Figure = OpenFile.Worksheets("2022 Monthly Forecast").Range("DJ59").Value
oFile.Offset(0, 12) = Figure
OpenFile.Close False
Next oFile
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Solution 1:[1]
Import Data From Workbooks
Option Explicit
Sub ImportForecastData()
' Source
Const sName As String = "2022 Monthly Forecast"
Const sCriteriaColumn As String = "B"
Const sCriteria As String = "Nights"
Const sColumnsList As String = "D,N,X,AH,AR,BB,BL,BV,CF,CP,CZ,DJ"
Const sColumnsDelimiter As String = ","
' Destination
Const dName As String = "File List"
Const dsFolderPathAddress As String = "A1"
Const dFirstCellAddress As String = "A2"
' Reference the destination workbook.
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
' Determine the source folder path.
Dim sFolderPath As String: sFolderPath = dws.Range(dsFolderPathAddress)
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
' Write the source columns to an array.
Dim sColumns() As String: sColumns = Split(sColumnsList, sColumnsDelimiter)
Dim sUpper As Long: sUpper = UBound(sColumns)
' Reference the destination lookup column range containing the file names.
Dim drg As Range
Dim drCount As Long
With dws.Range(dFirstCellAddress)
Dim dlCell As Range: Set dlCell = .Resize(dws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If dlCell Is Nothing Then Exit Sub ' no data in column range
drCount = dlCell.Row - .Row + 1
Set drg = .Resize(drCount)
End With
Application.ScreenUpdating = False
' Clear possible previous destination data (adjacent to the right
' of the destination lookup range).
drg.Offset(, 1).Resize(, sUpper + 1).Clear
Dim swb As Workbook
Dim sws As Worksheet
Dim srIndex As Variant
Dim sFileString As String
Dim sFileName As String
Dim sc As Long
Dim dCell As Range
' Loop through the file names.
For Each dCell In drg.Cells
' Attempt to open and reference the source workbook (file).
sFileString = CStr(dCell.Value)
If Len(sFileString) > 0 Then ' not a blank cell
sFileName = Dir(sFolderPath & sFileString)
If Len(sFileName) > 0 Then ' file exists
Set swb = Workbooks.Open(sFolderPath & sFileName)
' Attempt to reference the source worksheet.
On Error Resume Next
Set sws = swb.Worksheets(sName)
On Error GoTo 0
If Not sws Is Nothing Then ' worksheet exists
' Attempt to calculate the source criteria row index.
srIndex = Application.Match(sCriteria, _
sws.Columns(sCriteriaColumn), 0)
If IsNumeric(srIndex) Then ' criteria found
' Write the data.
For sc = 0 To sUpper
dCell.Offset(, sc + 1).Value _
= sws.Cells(srIndex, sColumns(sc))
Next sc
'Else ' criteria not found; do nothing
End If
Set sws = Nothing
'Else ' worksheet doesn't exist; do nothing
End If
' Close the source workbook.
swb.Close SaveChanges:=False
Set swb = Nothing
'Else ' file doesn't exist; do nothing
End If
'Else ' blank cell; do nothing
End If
Next dCell
' Save the destination workbook.
'dwb.Save
Application.ScreenUpdating = True
MsgBox "Forecast data imported.", vbInformation
End Sub
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 | VBasic2008 |
