Copying range to another book in fixed range

dinunan

New Member
Joined
Aug 17, 2017
Messages
33
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
 

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

ravisingh

New Member
Joined
Apr 5, 2019
Messages
46
Try this code - though the code could have been optimized, I have tried to just minimally modify your code...
Rich (BB 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
 
Last edited:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
How about:

Code:
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

New Member
Joined
Aug 17, 2017
Messages
33
@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.
 
Last edited:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

Try this:

Code:
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

New Member
Joined
Aug 17, 2017
Messages
33
Try this:

Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

In your original code you have a space after 19

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

If that space does not exist then use the following:

Code:
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

New Member
Joined
Aug 17, 2017
Messages
33
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,122,893
Messages
5,598,712
Members
414,254
Latest member
MarieCo

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top