Copy from mutiple sheets paste to separate workbook

[rbrunelle]

Hello,

I want to update weekly totals in my master excel file after copying a specific cell value from multiple sheets in source file.

My source data workbook contains 26 sheets each named with week ending date, i.e, "Feb 6 2016", "Feb 13 2106", etc...through end of Jul. I want to copy value in cell "L137" from each worksheet then paste this value to my master file.

My master workbook also contains many sheets, but I want to paste result to just one specific sheet, the wrinkle is value from each source worksheet must paste to next empty cell in column N beginning at cell N4 in master workbook.

Below is my VBA code which doesn't work, get run-time error 1004 copy method of range class failed. Any suggests are greatly appreciated.


Function IsWorkBookOpen(FileName As String)

Dim FF As Integer, ErrNum As Integer
On Error Resume Next
FF = FreeFile()
Open FileName For Input Lock Read As #FF
Close FF
ErrNum = Error
On Error GoTo 0
Select Case ErrNum
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNum
End Select

End Function
Public Function findnextempty(ByVal rcell As Range) As Range
On Error GoTo errorhandle
With rcell
If Len(.Formula) = 0 Then
Set findnextempty = rcell
ElseIf Len(.Offset(1, 0).Formula) = 0 Then
Set findnextempty = .Offset(1, 0)
Else
Set findnextempty = .End(xlDown).Offset(1, 0)
End If
End With

Exit Function
errorhandle: MsgBox Err.Description & ", function findnextempty."
End Function


Sub ExtractFromShippingDailyRpt()

Dim info2
info2 = IsWorkBookOpen("\\ssnetapp1\trans\shipping\production\By year\2016\Spring 2016 Mast Global Logistics Daily Report.xlsx")
If info2 = False Then
Workbooks.Open FileName:="\\ssnetapp1\trans\shipping\production\By year\2016\Spring 2016 Mast Global Logistics Daily Report.xlsx"
End If

Dim rcell As Range
Dim I As Integer
For I = 26 To 1 Step -1
Workbooks("Spring 2016 Mast Global Logistics Daily Report.xlsx").Worksheets(I).Range("L137").Copy _
Workbooks("2017 Shipping Model_AGGRESSIVE_rev01_dated 061217.xlsm").Sheets("BBW").Activate
Set rcell = findnextempty(Range("n1"))
ActiveSheet.Paste Destination:=Worksheets("BBW").Range("rcell")
rcell.Value = "filled by macro"
MsgBox rcell.Address & " " & rcell.Value
Set rcell = Nothing
Next I

End Sub

Kindly,
Rick

[rbrunelle]

UPDATED to simplify request...
Objective: copy data from a same cell reference across multiple worksheets in source workbook (book1.xlsx), then paste these values into specific worksheet, specific column in master workbook (book2.xlsx).
Both files attached here...

[jolivanes]

If you replace this

For I = 26 To 1 Step -1
Workbooks("Spring 2016 Mast Global Logistics Daily Report.xlsx").Worksheets(I).Range("L137").Copy _
Workbooks("2017 Shipping Model_AGGRESSIVE_rev01_dated 061217.xlsm").Sheets("BBW").Activate
Set rcell = findnextempty(Range("n1"))
ActiveSheet.Paste Destination:=Worksheets("BBW").Range("rcell")
rcell.Value = "filled by macro"
MsgBox rcell.Address & " " & rcell.Value
Set rcell = Nothing
Next I
by this

For I = 26 To 1 Step -1
With ThisWorkbook.Sheets("BBW") '<---- ThisWorkbook is the workbook with the code in it, the "Master"
If Len(.Cells(4, 14)) = 0 Then
nCell = 4
Else
nCell = .Cells(.Rows.Count, 14).End(xlUp).Row + 1
End If
.Cells(nCell, 14).Value = ActiveWorkbook.Sheets(I).Range("L137").Value '<---- Active Workbook is the workbook you opened and that should be the visible workbook
End With
Next I
does that make a difference?

I have not tried it so try it on copies of your workbooks

[rbrunelle]

Thank you for your suggestion, I updated vba code just now...it successfully copy and pasted data from 1st tab to 1st empty cell in Column N on tab "BBW", but stopped after that.

must not like my FOR Loop.

Any thoughts?

[rbrunelle]

I need the FOR Loop to step through each tab in the source workbook, copy data in cell L137 then paste that into next empty cell in column N in master workbook...

below is view of current vba code:


Function IsWorkBookOpen(FileName As String)

Dim FF As Integer, ErrNum As Integer
On Error Resume Next
FF = FreeFile()
Open FileName For Input Lock Read As #FF
Close FF
ErrNum = Error
On Error GoTo 0
Select Case ErrNum
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNum
End Select

End Function

Sub ExtractFromShippingDailyRpt()

Dim info2
info2 = IsWorkBookOpen("\\ssnetapp1\trans\shipping\production\By year\2016\Spring 2016 Mast Global Logistics Daily Report.xlsx")
If info2 = False Then
Workbooks.Open FileName:="\\ssnetapp1\trans\shipping\production\By year\2016\Spring 2016 Mast Global Logistics Daily Report.xlsx"
End If

Dim I As Integer
For I = 26 To 1 Step -1
With ThisWorkbook.Sheets("BBW") '<---- ThisWorkbook is the workbook with the code in it, the "Master"
If Len(.Cells(4, 14)) = 0 Then
nCell = 4
Else
nCell = .Cells(.Rows.Count, 14).End(xlUp).Row + 1
End If
.Cells(nCell, 14).Value = ActiveWorkbook.Sheets(I).Range("L137").Value '<---- Active Workbook is the workbook you opened and that should be the visible workbook
End With
Next I

End Sub

[jolivanes]

Please use code tags around your code when posting. Highlight your code and click on the # sign. It is required.

Try this. Check/Change references where required.

Sub Maybe_So()
Dim wb1 As Workbook, wb2 As Workbook, nCell As Long, i As Long
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook '<---- Master with code
On Error Resume Next
Set wb2 = Workbooks("C:\Test\rbrunelle.xlsm") '<---- Path and name of file to be copied from
If Err Then Set wb2 = Workbooks.Open("C:\Test\rbrunelle.xlsm") '<---- Path and name of file to be copied from
On Error GoTo 0
For i = 1 To wb2.Sheets.Count
With wb1.Sheets("Sheet2")
If Len(.Cells(4, 6)) = 0 Then
nCell = 4
Else
nCell = .Cells(.Rows.Count, 6).End(xlUp).Row + 1
End If
.Cells(nCell, 14).Value = wb2.Sheets(i).Cells(137, 12).Value
End With
Next i
wb2.Close False
Application.ScreenUpdating = True
End Sub

[rbrunelle]

Thank you Joli,

your suggestion works perfectly for first iteration, it successfully copies value from 1st tab in source file and pastes to first empty cell in column of master file. However, the FOR loop stops there it does not repeat for the other 25 tabs...

Updated code appears below:


Sub ExtractFromShippingDailyRpt()

Dim wb1 As Workbook, wb2 As Workbook, nCell As Long, i As Long
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
On Error Resume Next
Set wb2 = Workbooks("\\ssnetapp1\trans\shipping\production\By year\2016\Spring 2016 Mast Global Logistics Daily Report.xlsx")
If Err Then Set wb2 = Workbooks.Open("\\ssnetapp1\trans\shipping\production\By year\2016\Spring 2016 Mast Global Logistics Daily Report.xlsx")
On Error GoTo 0
For i = 26 To 1 Step -1
With wb1.Sheets("BBW")
If Len(.Cells(4, 14)) = 0 Then
nCell = 4
Else
nCell = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
End If
.Cells(nCell, 14).Value = wb2.Sheets(i).Cells(137, 12).Value
End With
Next i
wb2.Close False
Application.ScreenUpdating = True

End Sub

Thank you for your support.
Kindly,
Rick


Please use code tags around your code when posting. Highlight your code and click on the # sign. It is required.

Try this. Check/Change references where required.

Sub Maybe_So()
Dim wb1 As Workbook, wb2 As Workbook, nCell As Long, i As Long
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook '<---- Master with code
On Error Resume Next
Set wb2 = Workbooks("C:\Test\rbrunelle.xlsm") '<---- Path and name of file to be copied from
If Err Then Set wb2 = Workbooks.Open("C:\Test\rbrunelle.xlsm") '<---- Path and name of file to be copied from
On Error GoTo 0
For i = 1 To wb2.Sheets.Count
With wb1.Sheets("Sheet2")
If Len(.Cells(4, 6)) = 0 Then
nCell = 4
Else
nCell = .Cells(.Rows.Count, 6).End(xlUp).Row + 1
End If
.Cells(nCell, 14).Value = wb2.Sheets(i).Cells(137, 12).Value
End With
Next i
wb2.Close False
Application.ScreenUpdating = True
End Sub

[jolivanes]

Hi Rick.
Sorry to hear it is not doing what you want/need it to do. I works just fine on a test workbook I made.
Did you check if all the sheets indeed have a value/text in Cell L137?
The code is not overwriting data is it? (It shouldn't)

[rbrunelle]

SUCCESS! found my mistake, one of the column references was off.
Thanks for your help Jolivanes!

here's final code i ended up with:


Sub ExtractFromShippingDailyRpt()

'extract FALL LTD to NYCO LTD DC3

Dim wb1 As Workbook, wb2 As Workbook, nCell As Long, i As Long
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
On Error Resume Next
Set wb2 = Workbooks("\\ssnetapp1\trans\shipping\production\By year\2016\Fall 2016 Mast Global Logistics Daily Report.xlsx")
If Err Then Set wb2 = Workbooks.Open("\\ssnetapp1\trans\shipping\production\By year\2016\Fall 2016 Mast Global Logistics Daily Report.xlsx")
On Error GoTo 0
For i = 26 To 1 Step -1
With wb1.Sheets("NYCO LTD DC3")
If Len(.Cells(4, 22)) = 0 Then
nCell = 4
Else
nCell = .Cells(.Rows.Count, 22).End(xlUp).Row + 1
End If
.Cells(nCell, 22).Value = wb2.Sheets(i).Cells(127, 12).Value
End With
Next i
wb2.Close False
Application.ScreenUpdating = True

End Sub

[jolivanes]

Good to hear you have it working and found the little annoyance
Good luck