PDA

View Full Version : Solved: Copy Certain Rows into Master Workbook



demetre
08-30-2007, 05:08 AM
Afternoon Everyone

My issue involves copying entire rows 3:62 of a certain sheet then pasting (values) into a certain worksheet in a Master workbook. I have searched other posts but cannot find a solution. It should be simple, but it has eluded me... :dunno

Here is my code, I know it is bloated, but i will improve efficiency once everything is running as expected. I will be copying the same number of rows for each sheet, but there are 7 different worksheets I am working with. The Master sheet has 7 worksheets (PL, FM, CC, SM, RC, MF, OD) and I would like to paste using End(xlUp), so bottom up process to last row...


'/ Option Explicit
Sub LoopthruWorkbook()
'/ Declare variables used in function
Dim path As String '/Setup pathway
Dim Mstr As Workbook '/ Master workbook
Dim wb As Workbook '/ Workbook to be manipulated
Dim ws As Worksheet '/ Worksheet to be manipulated
Dim ShtName As String
Dim lastRow As Long
Dim LastRowSrc As Long
Dim LastRowDst As Long
Dim MyStr As String
Dim SelectCase As String
Dim WS_Count As Integer
Dim Per As String
Dim PL As String
Dim FM As String
Dim CC As String
Dim SM As String
Dim RC As String
Dim MF As String
Dim OD As String
PL = ("PL")
FM = ("FM")
CC = ("CC")
SM = ("SM")
RC = ("RC")
MF = ("MF")
OD = ("OD")
Set Mstr = ActiveWorkbook '/ Set Master workbook as Active
path = "\\ccd\dfsroot$\users\xxxxx\xxxxx\My (file://\\ccd\dfsroot$\users\xxxxx\xxxxx\My) Documents\xxxx\"
MsgBox "Pathway has been found: " & path
StrFile = Dir(path & "*.xls", vbNormal) '/ tell StrFile which path to take
Do Until StrFile = "" '/ Loop through all workbooks in folder via path
If StrFile <> "Master.xls" Then '/ Exclude Master workbook

Workbooks.Open path & StrFile
On Error Resume Next
Call UnProtectAll '/ Unprotect all worksheets in workbook
MsgBox "each worksheet is now unprotected"
'/ Name cell A1 & A2 with sheetname
Call SheetNameCell
' Set WS_Count equal to the number of worksheets in the active workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
MsgBox "number of worksheets in workbook:" & WS_Count
For Each ws In ActiveWorkbook.Worksheets '/ start for loop for each worksheet in workbook
ws.Activate '/ Activate worksheet during each iteration of the for loop due to some macros being recorded
Per = ws.Range("A2") '/ String in cell A2 dictates which macro called
MsgBox "A2 value is: " & Per & " of worksheet named: " & ws.Name

If Per = "PL" Then '/ If cell A2 = worksheet name (PL worksheet type)

Call LD3PL(sh:=ws) '/ PL sub call
MsgBox "called PL structure sub" '/ used for testing

Call Buff1 '/ Setup PL worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A

'/ **************************************************
'/ this is where I want to call copy, and then paste to Master in "PL" '/ worksheet
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("3:62" & lastRow).Copy
Mstr.Activate
Mstr.Sheets("PL").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

'/ ***************************************************

Else
If Per = "FM" Then '/ If cell A2 = worksheet name (FM worksheet type)

Call LD3FM(sh:=ws) '/ FM sub call
MsgBox "Called FM structure sub" '/ used for testing

Call Buff3 '/ Setup FM worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
ws.Range("3:62").Copy Mstr.Sheets("FM").Range("A65536").End(xlUp)
Else
If Per = "CC" Then '/ If cell A2 = worksheet name (FM worksheet type)

Call LD3CC(sh:=ws) '/ FM sub call
MsgBox "Called CC structure sub" '/ used for testing

Call Buff3 '/ Setup FM worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("CC").Range("A65536").End(xlUp)
Else
If Per = "SM" Then '/ If cell A2 = worksheet name (FM worksheet type)

Call LD3SM(sh:=ws) '/ FM sub call
MsgBox "Called SM structure sub" '/ used for testing

Call Buff2 '/ Setup SM worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("SM").Range("A65536").End(xlUp)
Else
If Per = "RC" Then '/ If cell A2 = worksheet name (FM worksheet type)

Call LD3RC(sh:=ws) '/ FM sub call
MsgBox "Called RC structure sub" '/ used for testing

Call Buff3 '/ Setup RC worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("RC").Range("A65536").End(xlUp)
Else
If Per = "MF" Then '/ If cell A2 = worksheet name (FM worksheet type)

Call LD3MF(sh:=ws) '/ FM sub call
MsgBox "Called MF structure sub" '/ used for testing

Call Buff2 '/ Setup MF worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("MF").Range("A65536").End(xlUp)

Else
If Per = "OD" Then '/ If cell A2 = worksheet name (FM worksheet type)

Call LD3OD(sh:=ws) '/ FM sub call
MsgBox "Called OD structure sub" '/ used for testing

Call Buff3 '/ Setup OD worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("OD").Range("A65536").End(xlUp)

Else
MsgBox "Error not correct format"
On Error GoTo 0

End If '/ End If statement
End If '/ End If statement
End If '/ End If statement
End If '/ End If statement
End If '/ End If statement
End If '/ End If statement
End If '/ End If statement

Next ws '/ End For loop

wb.Close False
End If '/ End If statement for StrFile != to Master

StrFile = Dir() '/ Find next workbook
Loop '/ End Do loop
End Sub
Private Sub ProtectAll()

Dim wsheet As Worksheet
Dim Pwd As String

For Each wsheet In Worksheets
wsheet.Protect Password:="gluestick"
Next wsheet

End Sub

Private Sub UnProtectAll()

Dim wsheet As Worksheet
Dim Pwd As String

For Each wsheet In Worksheets
wsheet.Unprotect Password:="gluestick"
Next wsheet

End Sub
Private Sub SheetNameCell()
Dim WS_Count As Integer '/ Total number of worksheets
Dim I As Integer '/ Start point
Dim WrkSht As Worksheet '/ Workbook
Dim MyStr As String
Dim String1 As String
Dim String2 As String
Dim Pivot As String
On Error Resume Next
For Each WrkSht In ActiveWorkbook.Worksheets
'/ Begin the loop

WrkSht.Range("A1") = WrkSht.Name
WrkSht.Range("HI1") = Range("A1")

'/ Breakup Sheetname
String1 = WrkSht.Range("A1") '/ Sheetname
String2 = WrkSht.Range("C5") '/ Cell name
WrkSht.Range("A3") = Mid(String2, 10, 2)
WrkSht.Range("A4") = Mid(String1, 10, 2)

'/ Compare Cell C5 against work sheetname to see what suits pivot point / naming convention
If String1 = String2 Then '/ If worksheet name and cell C5 match then use worksheet name as pivot point
WrkSht.Range("A2") = Mid(String1, 10, 2)
Else
If WrkSht.Range("A3") = "PL" Then
WrkSht.Range("A2") = WrkSht.Range("A3")
Else
If WrkSht.Range("A3") = "FM" Then
WrkSht.Range("A2") = WrkSht.Range("A3")
Else
If WrkSht.Range("A3") = "CC" Then
WrkSht.Range("A2") = WrkSht.Range("A3")
Else
If WrkSht.Range("A3") = "FM" Then
WrkSht.Range("A2") = WrkSht.Range("A3")
Else
If WrkSht.Range("A3") = "SM" Then
WrkSht.Range("A2") = WrkSht.Range("A3")
Else
If WrkSht.Range("A3") = "RC" Then
WrkSht.Range("A2") = WrkSht.Range("A3")
Else
If WrkSht.Range("A3") = "MF" Then
WrkSht.Range("A2") = WrkSht.Range("A3")
Else
If WrkSht.Range("A3") = "OD" Then
WrkSht.Range("A2") = WrkSht.Range("A3")
Else
If WrkSht.Range("A4") = "PL" Then
WrkSht.Range("A2") = WrkSht.Range("A4")
Else
If WrkSht.Range("A4") = "FM" Then
WrkSht.Range("A2") = WrkSht.Range("A4")
Else
If MWrkSht.Range("A4") = "CC" Then
WrkSht.Range("A2") = WrkSht.Range("A4")
Else
If WrkSht.Range("A4") = "FM" Then
WrkSht.Range("A2") = WrkSht.Range("A4")
Else
If WrkSht.Range("A4") = "SM" Then
WrkSht.Range("A2") = WrkSht.Range("A4")
Else
If WrkSht.Range("A4") = "RC" Then
WrkSht.Range("A2") = WrkSht.Range("A4")
Else
If WrkSht.Range("A4") = "MF" Then
WrkSht.Range("A2") = WrkSht.Range("A4")
Else
If WrkSht.Range("A4") = "OD" Then
WrkSht.Range("A2") = WrkSht.Range("A4")
Else
MsgBox "Incorrect naming convention used with worksheet: " & WrkSht.Name

On Error GoTo 0
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If

Next WrkSht '/ End For loop
End Sub
Private Sub Buff1() '/ PL worksheet setup only
Range("B3:B62").Cut Destination:=Range("C3:C62")
Range("D3").Copy Destination:=Range("D4:D62")
Range("E3").Copy Destination:=Range("E4:E62")
Range("F3").Copy Destination:=Range("F4:F62")
Range("G3").Copy Destination:=Range("G4:G62")
Range("H3").Copy Destination:=Range("H4:H62")
End Sub
Private Sub Buff2() '/ Setup worksheet for SM / MF
Range("D3").Copy Destination:=Range("D4:D62")
Range("E3").Copy Destination:=Range("E4:E62")
Range("F3").Copy Destination:=Range("F4:F62")
Range("G3").Copy Destination:=Range("G4:G62")
Range("H3").Copy Destination:=Range("H4:H62")
End Sub
Private Sub Buff3() '/ Setup worksheets FM / CC / RC / OD
Range("D3").Copy Destination:=Range("D4:D62")
Range("E3").Copy Destination:=Range("E4:E62")
Range("F3").Copy Destination:=Range("F4:F62")
Range("G3").Copy Destination:=Range("G4:G62")
End Sub
Private Sub Slim()
'/ Delete extra work sheet data
Range("63:65536").EntireRow.Delete

End Sub
Private Sub PivotBuff() '/ Buff Pivot
Dim WS_Count As Integer '/ Total number of worksheets
Dim I As Integer '/ Start point
Dim WrkSht As Worksheet '/ Workbook
Dim MyStr As String
Dim String1 As String
Dim String2 As String
Dim Pivot As String
On Error Resume Next
For Each WrkSht In ActiveWorkbook.Worksheets
'/ Begin the loop

WrkSht.Range("B3") = WrkSht.Name
WrkSht.Range("B4") = Range("D3")

'/ Breakup Sheetname
String1 = WrkSht.Range("B3") '/ Sheetname
String2 = WrkSht.Range("D3") '/ Cell name
WrkSht.Range("B5") = Mid(String2, 10, 2)
WrkSht.Range("B6") = Mid(String1, 10, 2)

If Mid(String1, 10, 2) = Mid(String2, 10, 2) Then
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B5") = "PL" Then
WrkSht.Range("D3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B5") = "FM" Then
WrkSht.Range("D3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B5") = "CC" Then
WrkSht.Range("D3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B5") = "FM" Then
WrkSht.Range("D3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B5") = "SM" Then
WrkSht.Range("D3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B5") = "RC" Then
WrkSht.Range("D3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B5") = "MF" Then
WrkSht.Range("D3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B5") = "OD" Then
WrkSht.Range("D3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B6") = "PL" Then
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B6") = "FM" Then
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If MWrkSht.Range("B6") = "CC" Then
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B6") = "FM" Then
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B6") = "SM" Then
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B6") = "RC" Then
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B6") = "MF" Then
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Else
If WrkSht.Range("B6") = "OD" Then
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Else
MsgBox "Error with Pivot Buff: " & WrkSht.Name

On Error GoTo 0
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If

Next WrkSht '/ End For loop
End Sub


Thanks again for your time

Bob Phillips
08-30-2007, 05:44 AM
I haven't looked at your code (life is too short), but copying is simple. Get the next free row on the MASTER and then just copy



With Activeworkbook.Worksheets("Sheet1)
LastRow = .Cells(.Rows.Count,"A").End(xlUp).Row
Activeworkbook.Worksheets("some other").Rows("3:62").Copy .Cells(lastRow+1,"A")
End With

demetre
08-30-2007, 06:29 AM
xld thank you for your reply

I agree copying should be simple... :banghead:

The worksheet from which I am copying has many differrent names(so static sheetname cannot be applied), but there is a naming convention used, thus I am able to extract a 2 character string, and call the relevant macro to manipulate the 7 different worksheets.

When I copy the rows it is in the current active worksheet (post manipulation), so all I need to do in reality is

ws.Range("3:62").EntireRow.Copy

but the issue I am having is pasting it another workbook with a specific worksheet

Mstr.Sheets("PL")..... where I paste from bottom to last row of that worksheet using End(xlUp)

I know this is extremely simple...

thanks

p45cal
08-30-2007, 10:06 AM
In the following code, I've made a suggestion regarding your copying problem. I have tested that bit and it seems to work ok.

I've also, and you'll hate this, made a few more changes/suggestions, mostly aimed at trying to trim down the code so that if changes have to be made you'll only have to change the code in one or two places rather than a whole raft of 'em. Comments in the code. Can't test it very well because I'd have to set up a bunch of workbooks and workshets with data in.

Anyway:Sub LoopthruWorkbook()
'/ Declare variables used in function
Dim path As String '/Setup pathway
Dim Mstr As Workbook '/ Master workbook
Dim wb As Workbook '/ Workbook to be manipulated
Dim ws As Worksheet '/ Worksheet to be manipulated
Dim ShtName As String
Dim lastRow As Long
Dim LastRowSrc As Long
Dim LastRowDst As Long
Dim MyStr As String
Dim SelectCase As String
Dim WS_Count As Integer
Dim Per As String
Dim PL As String
Dim FM As String
Dim CC As String
Dim SM As String
Dim RC As String
Dim MF As String
Dim OD As String
PL = ("PL")
FM = ("FM")
CC = ("CC")
SM = ("SM")
RC = ("RC")
MF = ("MF")
OD = ("OD")
Set Mstr = ActiveWorkbook '/ Set Master workbook as Active
path = "\\ccd\dfsroot$\users\xxxxx\xxxxx\My Documents\xxxx\"
MsgBox "Pathway has been found: " & path
StrFile = Dir(path & "*.xls", vbNormal) '/ tell StrFile which path to take
Do Until StrFile = "" '/ Loop through all workbooks in folder via path
If StrFile <> "Master.xls" Then '/ Exclude Master workbook

Workbooks.Open path & StrFile
On Error Resume Next
Call UnProtectAll '/ Unprotect all worksheets in workbook
MsgBox "each worksheet is now unprotected"
'/ Name cell A1 & A2 with sheetname
Call SheetNameCell
' Set WS_Count equal to the number of worksheets in the active workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
MsgBox "number of worksheets in workbook:" & WS_Count
For Each ws In ActiveWorkbook.Worksheets '/ start for loop for each worksheet in workbook
ws.Activate '/ Activate worksheet during each iteration of the for loop due to some macros being recorded
Per = ws.Range("A2") '/ String in cell A2 dictates which macro called
MsgBox "A2 value is: " & Per & " of worksheet named: " & ws.Name
'I note that the following blocks of code are quite similar and could be replaced with a single sub and have parameters passed to it. pd.
Select Case Per
Case "PL" '/ If cell A2 = worksheet name (PL worksheet type)
Call LD3PL(sh:=ws) '/ PL sub call
MsgBox "called PL structure sub" '/ used for testing
Call Buff1 '/ Setup PL worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
'/ **************************************************
'/ this is where I want to call copy, and then paste to Master in "PL" '/ worksheet
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
' ws.Range("3:" & lastRow).Copy
' Mstr.Activate
' Mstr.Sheets("PL").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
'Does this line (below) work? I've not used it again in the blocks below in case it's wrong. pd.
Mstr.Sheets("PL").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(lastRow - 3 + 1).EntireRow = ws.Range("3:" & lastRow).Value
'/ ***************************************************

Case "FM" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3FM(sh:=ws) '/ FM sub call
MsgBox "Called FM structure sub" '/ used for testing
Call Buff3 '/ Setup FM worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
ws.Range("3:62").Copy Mstr.Sheets("FM").Range("A65536").End(xlUp)

Case "CC" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3CC(sh:=ws) '/ FM sub call
MsgBox "Called CC structure sub" '/ used for testing
Call Buff3 '/ Setup FM worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("CC").Range("A65536").End(xlUp)

Case "SM" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3SM(sh:=ws) '/ FM sub call
MsgBox "Called SM structure sub" '/ used for testing
Call Buff2 '/ Setup SM worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("SM").Range("A65536").End(xlUp)

Case "RC" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3RC(sh:=ws) '/ FM sub call
MsgBox "Called RC structure sub" '/ used for testing
Call Buff3 '/ Setup RC worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("RC").Range("A65536").End(xlUp)

Case "MF" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3MF(sh:=ws) '/ FM sub call
MsgBox "Called MF structure sub" '/ used for testing
Call Buff2 '/ Setup MF worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("MF").Range("A65536").End(xlUp)

Case "OD" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3OD(sh:=ws) '/ FM sub call
MsgBox "Called OD structure sub" '/ used for testing
Call Buff3 '/ Setup OD worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("OD").Range("A65536").End(xlUp)

Case Else
MsgBox "Error not correct format"
On Error GoTo 0
End Select

Next ws '/ End For loop

wb.Close False
End If '/ End If statement for StrFile != to Master

StrFile = Dir() '/ Find next workbook
Loop '/ End Do loop
End Sub
Private Sub ProtectAll()

Dim wsheet As Worksheet
Dim Pwd As String

For Each wsheet In Worksheets
wsheet.Protect Password:="gluestick"
Next wsheet

End Sub

Private Sub UnProtectAll()

Dim wsheet As Worksheet
Dim Pwd As String

For Each wsheet In Worksheets
wsheet.Unprotect Password:="gluestick"
Next wsheet

End Sub
Private Sub SheetNameCell()
Dim WS_Count As Integer '/ Total number of worksheets
Dim I As Integer '/ Start point
Dim WrkSht As Worksheet '/ Workbook
Dim MyStr As String
Dim String1 As String
Dim String2 As String
Dim Pivot As String
On Error Resume Next
For Each WrkSht In ActiveWorkbook.Worksheets
'/ Begin the loop

WrkSht.Range("A1") = WrkSht.Name
WrkSht.Range("HI1") = Range("A1")

'/ Breakup Sheetname
String1 = WrkSht.Range("A1") '/ Sheetname
String2 = WrkSht.Range("C5") '/ Cell name
WrkSht.Range("A3") = Mid(String2, 10, 2)
WrkSht.Range("A4") = Mid(String1, 10, 2)

'/ Compare Cell C5 against work sheetname to see what suits pivot point / naming convention
If String1 = String2 Then '/ If worksheet name and cell C5 match then use worksheet name as pivot point
WrkSht.Range("A2") = Mid(String1, 10, 2)
Else
Select Case WrkSht.Range("A3")
Case "CC", "FM", "MF", "OD", "PL", "RC", "SM"
WrkSht.Range("A2") = WrkSht.Range("A3")
Case Else
Select Case WrkSht.Range("A4")
Case "PL", "CC", "FM", "MF", "OD", "RC", "SM"
WrkSht.Range("A2") = WrkSht.Range("A4")
Case Else
MsgBox "Incorrect naming convention used with worksheet: " & WrkSht.Name
On Error GoTo 0
End Select
End Select
End If
'is MWrkSht a typo for WrkSht? You have FM twice in both runs. pd.
Next WrkSht '/ End For loop
End Sub
Private Sub Buff1() '/ PL worksheet setup only
Range("B3:B62").Cut Destination:=Range("C3:C62")
Buff2
End Sub
Private Sub Buff2() '/ Setup worksheet for SM / MF
'This is also called by Buff1
Buff3
Range("H3").Copy Destination:=Range("H4:H62")
End Sub
Private Sub Buff3() '/ Setup worksheets FM / CC / RC / OD
'This is also called by Buff2
Range("D3").Copy Destination:=Range("D4:D62")
Range("E3").Copy Destination:=Range("E4:E62")
Range("F3").Copy Destination:=Range("F4:F62")
Range("G3").Copy Destination:=Range("G4:G62")
End Sub
Private Sub Slim()
'/ Delete extra work sheet data
Range("63:65536").EntireRow.Delete

End Sub
Private Sub PivotBuff() '/ Buff Pivot
Dim WS_Count As Integer '/ Total number of worksheets
Dim I As Integer '/ Start point
Dim WrkSht As Worksheet '/ Workbook
Dim MyStr As String
Dim String1 As String
Dim String2 As String
Dim Pivot As String
On Error Resume Next
For Each WrkSht In ActiveWorkbook.Worksheets
'/ Begin the loop

WrkSht.Range("B3") = WrkSht.Name
WrkSht.Range("B4") = Range("D3")

'/ Breakup Sheetname
String1 = WrkSht.Range("B3") '/ Sheetname
String2 = WrkSht.Range("D3") '/ Cell name
WrkSht.Range("B5") = Mid(String2, 10, 2)
WrkSht.Range("B6") = Mid(String1, 10, 2)

If Mid(String1, 10, 2) = Mid(String2, 10, 2) Then
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Else
Select Case WrkSht.Range("B5")
Case "CC", "FM", "FM", "MF", "OD", "PL", "RC", "SM"
WrkSht.Range("D3").Copy Destination:=WrkSht.Range("A3:A62")
Case Else
Select Case WrkSht.Range("B6")
Case "CC", "FM", "FM", "MF", "OD", "PL", "RC", "SM"
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Case Else
MsgBox "Error with Pivot Buff: " & WrkSht.Name
On Error GoTo 0
End Select
End Select
End If

Next WrkSht '/ End For loop
End Sub
p45cal

demetre
08-31-2007, 12:32 AM
P45cal thank you for your assistance but my issue is still present... :banghead:

The code bugs when it hits the following line, as it has for all my previous attempts...


Mstr.Sheets("PL").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(lastRow - 3 + 1).EntireRow = ws.Range("3:" & lastRow).Value


I get the following error
Run-time error '9':
Subscript out of range

does anyone have any further thoughts?:dunno

thanks

Bob Phillips
08-31-2007, 12:34 AM
That suggests that there is a not a worksheet called PL.

demetre
08-31-2007, 12:37 AM
That suggests that there is a not a worksheet called PL.

xld thank you... so thus the Mstr workbook does not exist or has not been initialised in relation to the code I have written...

thanks for the advice, ill look at it again now

demetre
08-31-2007, 03:57 AM
here is the code thus... thanks to p45cal for assisting in tidying it up

I am still getting errors as per xld's post regarding that the worksheet from the Master does not exist. I have initialised / declared the Master as Mstr, I have also Set is as an ActiveWorkbook.

this is the area where the code is failing. please tell me what i am doing wrong. Once this copy / paste method functions I should easily be able to import (with relevant changes) to the other Cases (FM, CC, etc)


Case "PL" '/ If cell A2 = worksheet name (PL worksheet type)

Call LD3PL(sh:=ws) '/ PL sub call
MsgBox "called PL structure sub" '/ used for testing

Call Buff1 '/ Setup PL worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A

lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row '/ Find last row in ws worskheet

Mstr.Activate

'/ In Master worksheet "PL" paste into last row
Sheets("PL").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(lastRow - 3 + 1).EntireRow = ws.Range("3:" & lastRow).Value




I am seriously lost now due to the error I keep getting. Any help as always is very appreciated

thanks



Sub LD3Extraction()
'/ Declare variables used in function
Dim path As String '/Setup pathway
Dim Mstr As Workbook '/ Master workbook
Dim wb As Workbook '/ Workbook to be manipulated
Dim ws As Worksheet '/ Worksheet to be manipulated
Dim ShtName As String
Dim lastRow As Long
Dim LastRowSrc As Long
Dim LastRowDst As Long
Dim MyStr As String
Dim SelectCase As String
Dim WS_Count As Integer
Dim Per As String
Dim PL As String
Dim FM As String
Dim CC As String
Dim SM As String
Dim RC As String
Dim MF As String
Dim OD As String
PL = ("PL")
FM = ("FM")
CC = ("CC")
SM = ("SM")
RC = ("RC")
MF = ("MF")
OD = ("OD")
'/ Application.ScreenUpdating = False

path = "\\xxxx\dfsroot$\users\redirection\xxxxxxx\My (file://\\xxxx\dfsroot$\users\redirection\xxxxxxx\My) Documents\xxxxx\"
MsgBox "Pathway has been found: " & path

Set Mstr = ActiveWorkbook '/ Set Master workbook as Active

StrFile = Dir(path & "*.xls", vbNormal) '/ tell StrFile which path to take

Do Until StrFile = "" '/ Loop through all workbooks in folder via path

Workbooks.Open "\\xxxx\dfsroot$\users\redirection\xxxxxx\My (file://\\xxxx\dfsroot$\users\redirection\xxxxxx\My) Documents\xxxxx\Master.xls"

If StrFile <> "Master.xls" Then '/ Exclude Master workbook

Workbooks.Open path & StrFile

On Error Resume Next

Set wb = ActiveWorkbook

Call UnProtectAll '/ Unprotect all worksheets in workbook
MsgBox "each worksheet is now unprotected"

'/ Name cell A1 & A2 with sheetname
Call SheetNameCell

' Set WS_Count equal to the number of worksheets in the active workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
MsgBox "number of worksheets in workbook:" & WS_Count

For Each ws In ActiveWorkbook.Worksheets '/ start for loop for each worksheet in workbook

ws.Activate '/ Activate worksheet during each iteration of the for loop due to some macros being recorded
Per = ws.Range("A2") '/ String in cell A2 dictates which macro called
MsgBox "A2 value is: " & Per & " of worksheet named: " & ws.Name
Select Case Per
Case "PL" '/ If cell A2 = worksheet name (PL worksheet type)

Call LD3PL(sh:=ws) '/ PL sub call
MsgBox "called PL structure sub" '/ used for testing

Call Buff1 '/ Setup PL worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A

lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row '/ Find last row in ws worskheet

Mstr.Activate

'/ In Master worksheet "PL" paste into last row
Sheets("PL").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(lastRow - 3 + 1).EntireRow = ws.Range("3:" & lastRow).Value

Case "FM" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3FM(sh:=ws) '/ FM sub call
MsgBox "Called FM structure sub" '/ used for testing
Call Buff3 '/ Setup FM worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
'/ Copy ws.Range ("3:62") to Master ("FM") last row

Case "CC" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3CC(sh:=ws) '/ FM sub call
MsgBox "Called CC structure sub" '/ used for testing
Call Buff3 '/ Setup FM worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("CC").Range("A65536").End(xlUp)

Case "SM" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3SM(sh:=ws) '/ FM sub call
MsgBox "Called SM structure sub" '/ used for testing
Call Buff2 '/ Setup SM worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("SM").Range("A65536").End(xlUp)

Case "RC" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3RC(sh:=ws) '/ FM sub call
MsgBox "Called RC structure sub" '/ used for testing
Call Buff3 '/ Setup RC worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("RC").Range("A65536").End(xlUp)

Case "MF" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3MF(sh:=ws) '/ FM sub call
MsgBox "Called MF structure sub" '/ used for testing
Call Buff2 '/ Setup MF worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("MF").Range("A65536").End(xlUp)

Case "OD" '/ If cell A2 = worksheet name (FM worksheet type)
Call LD3OD(sh:=ws) '/ FM sub call
MsgBox "Called OD structure sub" '/ used for testing
Call Buff3 '/ Setup OD worksheet
Call Slim '/ Delete Row 63+
Call PivotBuff '/ Setup pivot data in column A
Range("3:62").Copy Mstr.Sheets("OD").Range("A65536").End(xlUp)

Case Else
MsgBox "Error not correct format"
On Error GoTo 0
End Select

Next ws '/ End For loop

wb.Close False
End If '/ End If statement for StrFile != to Master

StrFile = Dir() '/ Find next workbook
Loop '/ End Do loop
End Sub
Private Sub ProtectAll()

Dim wsheet As Worksheet
Dim Pwd As String

For Each wsheet In Worksheets
wsheet.Protect Password:="gluestick"
Next wsheet

End Sub

Private Sub UnProtectAll()

Dim wsheet As Worksheet
Dim Pwd As String

For Each wsheet In Worksheets
wsheet.Unprotect Password:="gluestick"
Next wsheet

End Sub
Private Sub SheetNameCell()
Dim WS_Count As Integer '/ Total number of worksheets
Dim I As Integer '/ Start point
Dim WrkSht As Worksheet '/ Workbook
Dim MyStr As String
Dim String1 As String
Dim String2 As String
Dim Pivot As String
On Error Resume Next
For Each WrkSht In ActiveWorkbook.Worksheets '/ Begin the loop

WrkSht.Range("A1") = WrkSht.Name
WrkSht.Range("HI1") = Range("A1")

'/ Breakup Sheetname
String1 = WrkSht.Range("A1") '/ Sheetname
String2 = WrkSht.Range("C5") '/ Cell name
WrkSht.Range("A3") = Mid(String2, 10, 2)
WrkSht.Range("A4") = Mid(String1, 10, 2)

'/ Compare Cell C5 against work sheetname to see what suits pivot point / naming convention
If String1 = String2 Then '/ If worksheet name and cell C5 match then use worksheet name as pivot point
WrkSht.Range("A2") = Mid(String1, 10, 2)
Else
Select Case WrkSht.Range("A3")
Case "CC", "FM", "MF", "OD", "PL", "RC", "SM"
WrkSht.Range("A2") = WrkSht.Range("A3")
Case Else
Select Case WrkSht.Range("A4")
Case "PL", "CC", "FM", "MF", "OD", "RC", "SM"
WrkSht.Range("A2") = WrkSht.Range("A4")
Case Else
MsgBox "Incorrect naming convention used with worksheet: " & WrkSht.Name
On Error GoTo 0
End Select
End Select
End If
'is MWrkSht a typo for WrkSht? You have FM twice in both runs. pd.
Next WrkSht '/ End For loop
End Sub
Private Sub Buff1() '/ PL worksheet setup only
Range("B3:B62").Cut Destination:=Range("C3:C62")
Buff2
End Sub
Private Sub Buff2() '/ Setup worksheet for SM / MF
'This is also called by Buff1
Buff3
Range("H3").Copy Destination:=Range("H4:H62")
End Sub
Private Sub Buff3() '/ Setup worksheets FM / CC / RC / OD
'This is also called by Buff2
Range("D3").Copy Destination:=Range("D4:D62")
Range("E3").Copy Destination:=Range("E4:E62")
Range("F3").Copy Destination:=Range("F4:F62")
Range("G3").Copy Destination:=Range("G4:G62")
End Sub
Private Sub Slim()
'/ Delete extra work sheet data
Range("63:65536").EntireRow.Delete

End Sub
Private Sub PivotBuff() '/ Buff Pivot
Dim WS_Count As Integer '/ Total number of worksheets
Dim I As Integer '/ Start point
Dim WrkSht As Worksheet '/ Workbook
Dim MyStr As String
Dim String1 As String
Dim String2 As String
Dim Pivot As String
On Error Resume Next
For Each WrkSht In ActiveWorkbook.Worksheets
'/ Begin the loop

WrkSht.Range("B3") = WrkSht.Name
WrkSht.Range("B4") = Range("D3")

'/ Breakup Sheetname
String1 = WrkSht.Range("B3") '/ Sheetname
String2 = WrkSht.Range("D3") '/ Cell name
WrkSht.Range("B5") = Mid(String2, 10, 2)
WrkSht.Range("B6") = Mid(String1, 10, 2)

If Mid(String1, 10, 2) = Mid(String2, 10, 2) Then
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Else
Select Case WrkSht.Range("B5")
Case "CC", "FM", "MF", "OD", "PL", "RC", "SM"
WrkSht.Range("D3").Copy Destination:=WrkSht.Range("A3:A62")
Case Else
Select Case WrkSht.Range("B6")
Case "CC", "FM", "MF", "OD", "PL", "RC", "SM"
WrkSht.Range("B3").Copy Destination:=WrkSht.Range("A3:A62")
Case Else
MsgBox "Error with Pivot Buff: " & WrkSht.Name
On Error GoTo 0
End Select
End Select
End If

Next WrkSht '/ End For loop
End Sub

p45cal
08-31-2007, 05:28 AM
1. Put option explicit back in, this will help eliminate typos.
2. Remove On Error Resume Next unless absolutely required.
3. When the error turns up, click Debug, then look at the line causing problems, then look at the Locals window and see if all the objects etc. are what you think they should be. In the Immediate window, make sure things are what you expect them to be, eg. execute this sort of thing:
?Mstr.name
and check it returns the name you expect.
?Activeworkbook.name
?Activesheet.name
?ws.name
check that lastrow has a valid value:
?lastrow

Take parts of the line and execute them (or variations of them), eg.
Activate manually the sheet PL and execute
Sheets("PL").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(lastRow - 3 + 1).EntireRow.select
to see whether it selects anything at all.
Select the ws sheet and execute
ws.Range("3:" & lastRow).select

etc. etc.
At one point you'll get a similar error and you'll know what needs correcting.

4. Unknowns to members here are what happens in calls to subs not listed - I'm not suggesting you list them - but do they do things to objects/variables that upsets the code which errors? For example they might select/activate or open/close other sheets...

p45cal