Below is the macro I have to go to a certain file and combine all
spreadsheets. I did not write this macro myself. I just received it and
modified it to work for my situation. When this maco is run it gets to the
first file and says I cannot change a read only file and says I must
unprotect the worksheet. This sheet is not protected but I really only want
to copy the info on it anyway. Is there a way to modify this macro to copy
the information. I could save all of the "CS" files as new files but that
would defeat the purpose of automating this job
Any help is greatly appreciated.
Sub CollectAll()
On Error GoTo Exit_Line
Application.ScreenUpdating = False
Application.EnableEvents = False

Dim wbkTempBook As Workbook
Dim shtPasteSheet As Worksheet, shtTemp As Worksheet
Dim lngMaxRow As Long, lngCopyRows As Long, lngPasteRow As Long,
lngIgnoreRows As Long

lngPasteRow = 2 'Row to start copying to
lngIgnoreRows = 1 'Number of Rows to ignore

Set shtPasteSheet = ThisWorkbook.Sheets(1)

sFolderPath = "G:\Accounting\Invoicing\SHIPPING CHARGES\FebruaryClipper"

sTempName = Dir(sFolderPath & "\*cs")
Do While sTempName < ""
Set wbkTempBook = Workbooks.Open(sFolderPath & "\" & sTempName, True,
True)
Set shtTemp = wbkTempBook.Sheets(1)
lngMaxRow = shtTemp.Cells.SpecialCells(xlCellTypeLastCell).Row
lngCopyRows = lngMaxRow - lngIgnoreRows
If lngMaxRow lngIgnoreRows Then
shtTemp.Range("A" & lngIgnoreRows + 1 & ":V" & lngMaxRow).COPY _
shtPasteSheet.Range("A" & lngPasteRow & ":V" & lngPasteRow +
lngCopyRows - 1)
lngPasteRow = lngPasteRow + lngCopyRows
End If
wbkTempBook.Close (False)
sTempName = Dir
Loop

Exit_Line:
Application.EnableEvents = True
Application.ScreenUpdating = True
If Err.Number < 0 Then MsgBox Err.Description
End Sub

First, I think you should comment the "on error goto exit_line" line.

Then you'll see which line is really causing the trouble.

I bet you'll find that it's this one:

lngMaxRow = shtTemp.Cells.SpecialCells(xlCellTypeLastCell).Row

..specialcells doesn't play nicely with protected worksheets.

Is there some other way to determine the last row?

Maybe a column that's always filled in:

with shtTemp
lngMaxRow = .cells(.rows.count,"A").end(xlup).row
end with

I stole this from Debra Dalgleish's site:
http://www.contextures.com/xlfaqApp.html#Unused

Maybe you can include a version of it into your code. (I left the myLastCol in
just in case you ever needed it.)

Option Explicit
Sub testme()

Dim myLastRow As Long
Dim myLastCol As Long
Dim DummyRng As Range

myLastRow = 0
myLastCol = 0
With ActiveSheet
Set DummyRng = .UsedRange
On Error Resume Next
myLastRow = _
.Cells.Find("*", after:=.Cells(1), _
LookIn:=xlFormulas, lookat:=xlWhole, _
searchdirection:=xlPrevious, _
searchorder:=xlByRows).Row
myLastCol = _
.Cells.Find("*", after:=.Cells(1), _
LookIn:=xlFormulas, lookat:=xlWhole, _
searchdirection:=xlPrevious, _
searchorder:=xlByColumns).Column
On Error GoTo 0
End With

MsgBox myLastRow & vbLf & myLastCol

End Sub




Judyt wrote:

Below is the macro I have to go to a certain file and combine all
spreadsheets. I did not write this macro myself. I just received it and
modified it to work for my situation. When this maco is run it gets to the
first file and says I cannot change a read only file and says I must
unprotect the worksheet. This sheet is not protected but I really only want
to copy the info on it anyway. Is there a way to modify this macro to copy
the information. I could save all of the "CS" files as new files but that
would defeat the purpose of automating this job
Any help is greatly appreciated.
Sub CollectAll()
On Error GoTo Exit_Line
Application.ScreenUpdating = False
Application.EnableEvents = False

Dim wbkTempBook As Workbook
Dim shtPasteSheet As Worksheet, shtTemp As Worksheet
Dim lngMaxRow As Long, lngCopyRows As Long, lngPasteRow As Long,
lngIgnoreRows As Long

lngPasteRow = 2 'Row to start copying to
lngIgnoreRows = 1 'Number of Rows to ignore

Set shtPasteSheet = ThisWorkbook.Sheets(1)

sFolderPath = "G:\Accounting\Invoicing\SHIPPING CHARGES\FebruaryClipper"

sTempName = Dir(sFolderPath & "\*cs")
Do While sTempName < ""
Set wbkTempBook = Workbooks.Open(sFolderPath & "\" & sTempName, True,
True)
Set shtTemp = wbkTempBook.Sheets(1)
lngMaxRow = shtTemp.Cells.SpecialCells(xlCellTypeLastCell).Row
lngCopyRows = lngMaxRow - lngIgnoreRows
If lngMaxRow lngIgnoreRows Then
shtTemp.Range("A" & lngIgnoreRows + 1 & ":V" & lngMaxRow).COPY _
shtPasteSheet.Range("A" & lngPasteRow & ":V" & lngPasteRow +
lngCopyRows - 1)
lngPasteRow = lngPasteRow + lngCopyRows
End If
wbkTempBook.Close (False)
sTempName = Dir
Loop

Exit_Line:
Application.EnableEvents = True
Application.ScreenUpdating = True
If Err.Number < 0 Then MsgBox Err.Description
End Sub

--

Dave Peterson