Group,
I've written a macro to copy a part of a row from one workbook into another. This macro has run for many hours without fail (it's moved data from 14,400 workbooks so far). Unfortunately it is stopping on one specific workbook and I can't figure out why. Here's the code I've written:
Sub GetSTRData()
For rowNo = 2 To 500
propNo = Sheets("Property Data").Cells(rowNo, 2).Value
region = Sheets("Property Data").Cells(rowNo, 14).Value
If Not propNo > 0 Then
Exit Sub
End If
If region = "CA" Then
sCurrency = "CAD"
sCountry = "NON US "
Else
sCurrency = "USD"
sCountry = "US "
End If
For iYear = 2011 To 2015
sYear = iYear
For iMonth = 1 To 12
If iMonth < 10 Then
sMonth = "0" & iMonth
End If
If iMonth > 9 Then
sMonth = iMonth
End If
If iMonth = 1 Then
sMName = "January"
End If
If iMonth = 2 Then
sMName = "February"
End If
If iMonth = 3 Then
sMName = "March"
End If
If iMonth = 4 Then
sMName = "April"
End If
If iMonth = 5 Then
sMName = "May"
End If
If iMonth = 6 Then
sMName = "June"
End If
If iMonth = 7 Then
sMName = "July"
End If
If iMonth = 8 Then
sMName = "August"
End If
If iMonth = 9 Then
sMName = "September"
End If
If iMonth = 10 Then
sMName = "October"
End If
If iMonth = 11 Then
sMName = "November"
End If
If iMonth = 12 Then
sMName = "December"
End If
histPath = "O:\Smith Travel Reports (STR)\Monthly STR Reports\" & sCountry & sYear & "\" & sMonth & " " & sMName & "\" & propNo & "-" & sYear & sMonth & "00" & "-" & sCurrency & "-E.xls"""
openFileName = propNo & "-" & sYear & sMonth & "00" & "-" & sCurrency & "-E.xls"
fileDateVal = DateValue(sMonth & "/1/" & sYear)
' Finding PIN and Matching Date on DATA tab
For pinRow = 2 To 2000000
pinNo = Workbooks("STR Data Import.xlsm").Sheets("DATA").Cells(pinRow, 1).Value
dateVal = Workbooks("STR Data Import.xlsm").Sheets("DATA").Cells(pinRow, 2).Value
If pinNo = propNo And dateVal = fileDateVal Then
pasteRow = pinRow
Exit For
End If
Next pinRow
If Dir(histPath) <> "" Then
Workbooks.Open Filename:=histPath
' Get historical Data
' Occupancy Data (getting OCC%)
Windows(openFileName).Activate
sheetCount = ActiveWorkbook.Worksheets.Count
exists = False
For sheetNo = 1 To sheetCount
If ActiveWorkbook.Worksheets(sheetNo).Name = "Daily by Month" Then
exists = True
End If
Next sheetNo
If exists = True Then
Sheets("Daily by Month").Activate
Range("C26:AG26").Activate
If srow = "02" Then
Range("C26:AE26").Activate
End If
If srow = "04" Then
Range("C26:AF26").Activate
End If
If srow = "06" Then
Range("C26:AF26").Activate
End If
If srow = "09" Then
Range("C26:AF26").Activate
End If
If srow = "11" Then
Range("C26:AF26").Activate
End If
Selection.Copy
BPastePoint = "C" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(BPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.0"
' Occupancy Data (getting Compset OCC%)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C27:AG27").Activate
If srow = "02" Then
Range("C27:AE27").Activate
End If
If srow = "04" Then
Range("C27:AF27").Activate
End If
If srow = "06" Then
Range("C27:AF27").Activate
End If
If srow = "09" Then
Range("C27:AF27").Activate
End If
If srow = "11" Then
Range("C27:AF27").Activate
End If
Selection.Copy
BPastePoint = "D" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(BPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.0"
' ADR Data (getting ADR)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C36:AG36").Activate
If srow = "02" Then
Range("C36:AE36").Activate
End If
If srow = "04" Then
Range("C36:AF36").Activate
End If
If srow = "06" Then
Range("C36:AF36").Activate
End If
If srow = "09" Then
Range("C36:AF36").Activate
End If
If srow = "11" Then
Range("C36:AF36").Activate
End If
Selection.Copy
CPastePoint = "E" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(CPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
' ADR Data (getting Compset ADR)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C37:AG37").Activate
If srow = "02" Then
Range("C37:AE37").Activate
End If
If srow = "04" Then
Range("C37:AF37").Activate
End If
If srow = "06" Then
Range("C37:AF37").Activate
End If
If srow = "09" Then
Range("C37:AF37").Activate
End If
If srow = "11" Then
Range("C37:AF37").Activate
End If
Selection.Copy
CPastePoint = "F" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(CPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
' RevPar Data (getting RevPar)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C46:AG46").Activate
If srow = "02" Then
Range("C46:AE46").Activate
End If
If srow = "04" Then
Range("C46:AF46").Activate
End If
If srow = "06" Then
Range("C46:AF46").Activate
End If
If srow = "09" Then
Range("C46:AF46").Activate
End If
If srow = "11" Then
Range("C46:AF46").Activate
End If
Selection.Copy
DPastePoint = "G" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(DPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
' RevPar Data (getting Compset RevPar)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C47:AG47").Activate
If srow = "02" Then
Range("C47:AE47").Activate
End If
If srow = "04" Then
Range("C47:AF47").Activate
End If
If srow = "06" Then
Range("C47:AF47").Activate
End If
If srow = "09" Then
Range("C47:AF47").Activate
End If
If srow = "11" Then
Range("C47:AF47").Activate
End If
Selection.Copy
DPastePoint = "H" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(DPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
' RPIPC Data (getting RPIPC)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C52:AG52").Activate
If srow = "02" Then
Range("C52:AE52").Activate
End If
If srow = "04" Then
Range("C52:AF52").Activate
End If
If srow = "06" Then
Range("C52:AF52").Activate
End If
If srow = "09" Then
Range("C52:AF52").Activate
End If
If srow = "11" Then
Range("C52:AF52").Activate
End If
Selection.Copy
DPastePoint = "I" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(DPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
Windows(openFileName).Activate
Application.DisplayAlerts = False
Workbooks(openFileName).Close True
Application.DisplayAlerts = True
If iYear = 2015 And iMonth = 10 Then
Windows("STR Data Import.xlsm").Activate
ActiveWorkbook.Save
End If
Else
Windows(openFileName).Activate
Application.DisplayAlerts = False
Workbooks(openFileName).Close True
Application.DisplayAlerts = True
Windows("STR Data Import.xlsm").Activate
End If
End If
Next iMonth
Next iYear
Next rowNo
Columns("C:I").Activate
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1").Activate
Windows("STR Data Import.xlsm").Activate
ActiveWorkbook.Save
End Sub
The script is failing at
"Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True"
However it doesn't stop until I get to the April 2013 version of the workbook that is holding the data I need. I suppose there is something different about this workbook. However I can't seem to find what it might be. Any thoughts?
In advance, thanks for your assistance.
Don
I've written a macro to copy a part of a row from one workbook into another. This macro has run for many hours without fail (it's moved data from 14,400 workbooks so far). Unfortunately it is stopping on one specific workbook and I can't figure out why. Here's the code I've written:
Sub GetSTRData()
For rowNo = 2 To 500
propNo = Sheets("Property Data").Cells(rowNo, 2).Value
region = Sheets("Property Data").Cells(rowNo, 14).Value
If Not propNo > 0 Then
Exit Sub
End If
If region = "CA" Then
sCurrency = "CAD"
sCountry = "NON US "
Else
sCurrency = "USD"
sCountry = "US "
End If
For iYear = 2011 To 2015
sYear = iYear
For iMonth = 1 To 12
If iMonth < 10 Then
sMonth = "0" & iMonth
End If
If iMonth > 9 Then
sMonth = iMonth
End If
If iMonth = 1 Then
sMName = "January"
End If
If iMonth = 2 Then
sMName = "February"
End If
If iMonth = 3 Then
sMName = "March"
End If
If iMonth = 4 Then
sMName = "April"
End If
If iMonth = 5 Then
sMName = "May"
End If
If iMonth = 6 Then
sMName = "June"
End If
If iMonth = 7 Then
sMName = "July"
End If
If iMonth = 8 Then
sMName = "August"
End If
If iMonth = 9 Then
sMName = "September"
End If
If iMonth = 10 Then
sMName = "October"
End If
If iMonth = 11 Then
sMName = "November"
End If
If iMonth = 12 Then
sMName = "December"
End If
histPath = "O:\Smith Travel Reports (STR)\Monthly STR Reports\" & sCountry & sYear & "\" & sMonth & " " & sMName & "\" & propNo & "-" & sYear & sMonth & "00" & "-" & sCurrency & "-E.xls"""
openFileName = propNo & "-" & sYear & sMonth & "00" & "-" & sCurrency & "-E.xls"
fileDateVal = DateValue(sMonth & "/1/" & sYear)
' Finding PIN and Matching Date on DATA tab
For pinRow = 2 To 2000000
pinNo = Workbooks("STR Data Import.xlsm").Sheets("DATA").Cells(pinRow, 1).Value
dateVal = Workbooks("STR Data Import.xlsm").Sheets("DATA").Cells(pinRow, 2).Value
If pinNo = propNo And dateVal = fileDateVal Then
pasteRow = pinRow
Exit For
End If
Next pinRow
If Dir(histPath) <> "" Then
Workbooks.Open Filename:=histPath
' Get historical Data
' Occupancy Data (getting OCC%)
Windows(openFileName).Activate
sheetCount = ActiveWorkbook.Worksheets.Count
exists = False
For sheetNo = 1 To sheetCount
If ActiveWorkbook.Worksheets(sheetNo).Name = "Daily by Month" Then
exists = True
End If
Next sheetNo
If exists = True Then
Sheets("Daily by Month").Activate
Range("C26:AG26").Activate
If srow = "02" Then
Range("C26:AE26").Activate
End If
If srow = "04" Then
Range("C26:AF26").Activate
End If
If srow = "06" Then
Range("C26:AF26").Activate
End If
If srow = "09" Then
Range("C26:AF26").Activate
End If
If srow = "11" Then
Range("C26:AF26").Activate
End If
Selection.Copy
BPastePoint = "C" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(BPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.0"
' Occupancy Data (getting Compset OCC%)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C27:AG27").Activate
If srow = "02" Then
Range("C27:AE27").Activate
End If
If srow = "04" Then
Range("C27:AF27").Activate
End If
If srow = "06" Then
Range("C27:AF27").Activate
End If
If srow = "09" Then
Range("C27:AF27").Activate
End If
If srow = "11" Then
Range("C27:AF27").Activate
End If
Selection.Copy
BPastePoint = "D" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(BPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.0"
' ADR Data (getting ADR)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C36:AG36").Activate
If srow = "02" Then
Range("C36:AE36").Activate
End If
If srow = "04" Then
Range("C36:AF36").Activate
End If
If srow = "06" Then
Range("C36:AF36").Activate
End If
If srow = "09" Then
Range("C36:AF36").Activate
End If
If srow = "11" Then
Range("C36:AF36").Activate
End If
Selection.Copy
CPastePoint = "E" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(CPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
' ADR Data (getting Compset ADR)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C37:AG37").Activate
If srow = "02" Then
Range("C37:AE37").Activate
End If
If srow = "04" Then
Range("C37:AF37").Activate
End If
If srow = "06" Then
Range("C37:AF37").Activate
End If
If srow = "09" Then
Range("C37:AF37").Activate
End If
If srow = "11" Then
Range("C37:AF37").Activate
End If
Selection.Copy
CPastePoint = "F" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(CPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
' RevPar Data (getting RevPar)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C46:AG46").Activate
If srow = "02" Then
Range("C46:AE46").Activate
End If
If srow = "04" Then
Range("C46:AF46").Activate
End If
If srow = "06" Then
Range("C46:AF46").Activate
End If
If srow = "09" Then
Range("C46:AF46").Activate
End If
If srow = "11" Then
Range("C46:AF46").Activate
End If
Selection.Copy
DPastePoint = "G" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(DPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
' RevPar Data (getting Compset RevPar)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C47:AG47").Activate
If srow = "02" Then
Range("C47:AE47").Activate
End If
If srow = "04" Then
Range("C47:AF47").Activate
End If
If srow = "06" Then
Range("C47:AF47").Activate
End If
If srow = "09" Then
Range("C47:AF47").Activate
End If
If srow = "11" Then
Range("C47:AF47").Activate
End If
Selection.Copy
DPastePoint = "H" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(DPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
' RPIPC Data (getting RPIPC)
Windows(openFileName).Activate
Sheets("Daily by Month").Activate
Range("C52:AG52").Activate
If srow = "02" Then
Range("C52:AE52").Activate
End If
If srow = "04" Then
Range("C52:AF52").Activate
End If
If srow = "06" Then
Range("C52:AF52").Activate
End If
If srow = "09" Then
Range("C52:AF52").Activate
End If
If srow = "11" Then
Range("C52:AF52").Activate
End If
Selection.Copy
DPastePoint = "I" & pasteRow
Windows("STR Data Import.xlsm").Activate
Sheets("DATA").Activate
Range(DPastePoint).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
Windows(openFileName).Activate
Application.DisplayAlerts = False
Workbooks(openFileName).Close True
Application.DisplayAlerts = True
If iYear = 2015 And iMonth = 10 Then
Windows("STR Data Import.xlsm").Activate
ActiveWorkbook.Save
End If
Else
Windows(openFileName).Activate
Application.DisplayAlerts = False
Workbooks(openFileName).Close True
Application.DisplayAlerts = True
Windows("STR Data Import.xlsm").Activate
End If
End If
Next iMonth
Next iYear
Next rowNo
Columns("C:I").Activate
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1").Activate
Windows("STR Data Import.xlsm").Activate
ActiveWorkbook.Save
End Sub
The script is failing at
"Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True"
However it doesn't stop until I get to the April 2013 version of the workbook that is holding the data I need. I suppose there is something different about this workbook. However I can't seem to find what it might be. Any thoughts?
In advance, thanks for your assistance.
Don