Copying range to another book in fixed range

[dinunan]

Hi

I've one workbook that contains 31 sheets (1 for each day). I want macro to open source workbook and loop through each sheet and copy range H15:H28 and paste it in active (Target) workbook from B4. I've code that does the job. But I want some change. After pasting in 16 columns i.e. up to Q4, next pasting should start from B20.

Here is the code

Sub UtilityConsumption()


Dim ws As Worksheet
Dim TargetWb As Workbook
Dim SourceWb As Workbook
Range("B4").Activate

Application.ScreenUpdating = False
Set TargetWb = ActiveWorkbook
Set SourceWb = Workbooks.Open("X:\XXX\XXX.xlsm")

SourceWb.Worksheets("1 April 2019 ").Activate

For Each ws In Sheets
Range("H15:H28").Copy

TargetWb.Activate
ActiveCell.Offset(0, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ActiveCell.Offset(0, 1).Range("A1").Select
SourceWb.Activate

ActiveSheet.Previous.Select
On Error GoTo exiterr
Next ws
exiterr:

Application.CutCopyMode = False
SourceWb.Close


End Sub

 

[ravisingh]

Try this code - though the code could have been optimized, I have tried to just minimally modify your code...

Sub UtilityConsumption()


Dim ws As Worksheet
Dim TargetWb As Workbook
Dim SourceWb As Workbook
Range("B4").Activate
ctr=1
Application.ScreenUpdating = False
Set TargetWb = ActiveWorkbook
Set SourceWb = Workbooks.Open("X:\XXX\XXX.xlsm")

SourceWb.Worksheets("1 April 2019 ").Activate

For Each ws In Sheets
Range("H15:H28").Copy

TargetWb.Activate
ActiveCell.Offset(0, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ctr=ctr+1
If ctr=17 Then Range("A20").Select
ActiveCell.Offset(0, 1).Range("A1").Select
SourceWb.Activate

ActiveSheet.Previous.Select
On Error GoTo exiterr
Next ws
exiterr:

Application.CutCopyMode = False
SourceWb.Close


End Sub

 

[DanteAmor]

How about:

Sub UtilityConsumption()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim i As Long, j As Long
    
    Application.ScreenUpdating = False
    Set wb1 = ActiveWorkbook
    Set ws1 = wb1.ActiveSheet
    Set wb2 = Workbooks.Open("X:\XXX\XXX.xlsm")
    
    i = 4
    j = 2
    For Each ws2 In wb2.Sheets
        ws2.Range("H15:H28").Copy
        ws1.Cells(i, j).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        j = j + 1
        If j = 17 Then
            i = 4 + 16
            j = 2
        End If
    Next
    wb2.Close False
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

 

[dinunan]

@ravi

Its working as I want.
@DanteAmor

Code is working fine but not how I want it. I want code to run from right to left on the sheets. We are keeping one sheet each for a day with latest on the left (the first sheet). Your code runs from left to right and so the pasting gets reverse dates. Also I've one extra sheet from previous month to omit. Thats the reason I ask the code to set "01 Apr 2019" as starting sheet and run on previous sheets.

 

[DanteAmor]

Try this:

Sub UtilityConsumption()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim i As Long, j As Long, n As Long
    
    Application.ScreenUpdating = False
    Set wb1 = ActiveWorkbook
    Set ws1 = wb1.ActiveSheet
    Set wb2 = Workbooks.Open("X:\XXX\XXX.xlsm")


    i = 4
    j = 2
    For n = wb2.Worksheets("1 April 2019 ").Index To 1 Step -1
        Set ws2 = wb2.Sheets(n)
        ws2.Range("H15:H28").Copy
        ws1.Cells(i, j).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        j = j + 1
        If j = 17 Then
            i = 4 + 16
            j = 2
        End If
    Next
    wb2.Close False
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

 

[dinunan]

Try this:

Sub UtilityConsumption()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim i As Long, j As Long, n As Long
    
    Application.ScreenUpdating = False
    Set wb1 = ActiveWorkbook
    Set ws1 = wb1.ActiveSheet
    Set wb2 = Workbooks.Open("X:\XXX\XXX.xlsm")


    i = 4
    j = 2
    For n = wb2.Worksheets("1 April 2019 ").Index To 1 Step -1
        Set ws2 = wb2.Sheets(n)
        ws2.Range("H15:H28").Copy
        ws1.Cells(i, j).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        j = j + 1
        If j = 17 Then
            i = 4 + 16
            j = 2
        End If
    Next
    wb2.Close False
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

Code halts with yellow highlight on the line
For n = wb2.Worksheets("1 April 2019 ").Index To 1 Step -1

The source file is opened and "10 Apr 2019" sheet is active.
and throws Run time error (9) script out of range

 

[DanteAmor]

In your original code you have a space after 19

[COLOR=#333333]SourceWb.Worksheets("1 April 2019 ").Activate[/COLOR]

If that space does not exist then use the following:

Sub UtilityConsumption()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim i As Long, j As Long, n As Long
    
    Application.ScreenUpdating = False
    Set wb1 = ActiveWorkbook
    Set ws1 = wb1.ActiveSheet
    Set wb2 = Workbooks.Open("X:\XXX\XXX.xlsm")




    i = 4
    j = 2
    For n = wb2.Worksheets("[COLOR=#0000ff]1 April 2019[/COLOR]").Index To 1 Step -1
        Set ws2 = wb2.Sheets(n)
        ws2.Range("H15:H28").Copy
        ws1.Cells(i, j).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        j = j + 1
        If j = 17 Then
            i = 4 + 16
            j = 2
        End If
    Next
    wb2.Close False
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

it usually happens, that way you experiment and learn more.

 

[dinunan]

Space was indeed there. I removed those spaces wherever existed and run the code. But this time, after pasting for 15 dates (and not 16 dates) it jumped down.
Changed the j value from 17 to 18 and now it works as I want it.

Thanks for the help and advice.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.