Macro to Copy sections from one sheet to another

rahildhody

New Member
Joined
Aug 4, 2016
Messages
28
Hi all,

I've been trying to copy sections from "Template" sheet & paste it in the "Output" sheet as per the attached file.

The sections are highlighted in yellow and I have produced how I would like the "Output" sheet to ultimately look like once the macro is completed. I'd like to copy all of the yellow highlighted sections from the "Template" sheet and keep pasting in the last found row in the "Output" sheet. Copying has to occur till row 637.

I can write the code to copy "B84:E87", paste in Output sheet ("B3:E6"), then copy "O84:BV87" from Template sheet & paste in output sheet ("F3:BM6"), then repeat the process for the next section "B109:E112" & "O109:BV112" in template sheet and paste in the next found lastrow (row7) in output sheet and keep repeating until all yellow highlighted sections until row 637 have been copied from the template sheet into the output sheet.

VBA Code:
'''''Section 1
Sheets("Template").range("B84:E87").copy
Sheets("Output").range("B3").PasteSpecial paste:=xlpasteValues

Sheets("Template").range("O84:BV87").copy
Sheets("Output").range("F3").PasteSpecial paste:=xlpasteValues

lastrow = Sheets("Output").Range("B" & .Rows.Count).End(xlUp).Row
''''lastrow = 6

'''''Section 2
Sheets("Template").range("B109:E112").copy
Sheets("Output").range("B" & lastrow+1).PasteSpecial paste:=xlpasteValues

Sheets("Template").range("O109:BV112").copy
Sheets("Output").range("F" & lastrow+1).PasteSpecial paste:=xlpasteValues

lastrow = Sheets("Output").Range("B" & .Rows.Count).End(xlUp).Row
''''lastrow = 10

'''''Section 3
Sheets("Template").range("B119:E122").copy
Sheets("Output").range("B" & lastrow+1).PasteSpecial paste:=xlpasteValues

Sheets("Template").range("O119:BV122").copy
Sheets("Output").range("F" & lastrow+1).PasteSpecial paste:=xlpasteValues

lastrow = Sheets("Output").Range("B" & .Rows.Count).End(xlUp).Row


'''''and so on till all highlighted sections until row 637 have been copied and pasted into Output sheet

Would appreciate any help in generating this code that is more efficient than the code above.
 

Attachments

  • Output Sheet.JPG
    Output Sheet.JPG
    200.2 KB · Views: 7
  • Template 1.JPG
    Template 1.JPG
    163.2 KB · Views: 7
  • Template 2.JPG
    Template 2.JPG
    190.5 KB · Views: 7

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

HaHoBe

Active Member
Joined
Jan 24, 2003
Messages
497
Office Version
  1. 2013
Platform
  1. Windows
Hi rahildhody,

maybe try this code on a copy of your worlbook:
VBA Code:
Dim NextRow As Long
Dim lngCounter As Long
Dim wsTemp As Worksheet
Dim wsTarg As Worksheet

Set wsTemp = Worksheets("Template")
Set wsTarg = Worksheets("Output")

wsTemp.Range("B84:E87").Copy
wsTarg.Range("B3").PasteSpecial Paste:=xlPasteValues

wsTemp.Range("O84:BV87").Copy
wsTarg.Range("F3").PasteSpecial Paste:=xlPasteValues

For lngcounte = 119 To 637 Step 10
  NextRow = wsTarg.Range("B" & .Rows.Count).End(xlUp).Row + 1
  wsTemp.Range("B" & lngCounter).Resize(4, 4).Copy
  wsTarg.Range("B" & NextRow).PasteSpecial Paste:=xlPasteValues

  wsTemp.Range("O" & lngCounter).Resize(4, 60).Copy
  wsTarg.Range("F" & NextRow).PasteSpecial Paste:=xlPasteValues
Next lngCounter
Ciao,
Holger
 

rahildhody

New Member
Joined
Aug 4, 2016
Messages
28
Hi Holger,

Thanks for your prompt response. I did use & understand your code but it still doesn't entirely solve the issue unfortunately for the reasons below:

1) Although the columns to be copied are 4 (B:E) & 60 (O:BV), the rows of the section to be copied isnt always 4, so the .resize(4,4) & .resize(4,60) fails
2) The gap between copying the sections isnt always 10, so the Step 10 fails to execute the correct approach.

Been thinking about how else we can solve this & came up with an approach. Perhaps using a helper column on the left that uses a formula "if some value in the legal entity then 'x', else blank" and then applying a filter from row 83 to the end of the sheet and filtering for all "x" in the helper column and then copying all the info from column B:E and subsequently O:BV and pasting in the output sheet.

Or might not even need to use a helper column & just filter for everything except blanks in "Legal Entity" column (column B) and do the same as above.

Could you assist me with a code for the above approach, unless you can come up with a better solution

Appreciate your help :)
 

Attachments

  • Capture.JPG
    Capture.JPG
    160.7 KB · Views: 3
Last edited:

rahildhody

New Member
Joined
Aug 4, 2016
Messages
28
Giving you a bit more context:

I have another code that creates copies of the "Template" sheet and renames it based on the range in the "References" sheet. Idea is for the code to loop through every single sheet that is created using the below macro and copy paste the entity info (columns B:E and O:BV) from each one of those sheets into the Master Output sheet

VBA Code:
Sub Create()
    Dim rng As Range, rngLoop As Range, ws As Worksheet, wb As Workbook
   
    Set wb = ThisWorkbook
   
    If Not SheetExists("Template") Then
        MsgBox "The Template sheet does not exist. Make sure the Template is included before processing.", vbCritical + vbOKOnly
        Exit Sub
    End If
   
    Application.ScreenUpdating = False
   
    With wb.Sheets("References")
        Set rng = .Range("M23", "M" & .Cells(Rows.Count, "M").End(xlUp).Row)
           
        For Each rngLoop In rng
            If rngLoop.Offset(0, 2) = "x" Then
                If Not SheetExists(rngLoop.Value) Then
                    wb.Sheets("Template").Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
                    Set ws = ActiveSheet
                    ws.Name = rngLoop.Value
                Else
                    Set ws = wb.Sheets(rngLoop.Value)
                End If
            Else
             GoTo nxtRng
            End If
       
nxtRng:
        Next
        .Activate
    End With
   
    Application.ScreenUpdating = True
End Sub


Sub DeleteSheets()
    Dim rng As Range, rngLoop As Range, ws As Worksheet, wb As Workbook
   
    Set wb = ThisWorkbook
   
    Application.ScreenUpdating = False
   
    With wb.Sheets("References")
        Set rng = .Range("M23", "M" & .Cells(Rows.Count, "M").End(xlUp).Row)
           
        For Each rngLoop In rng
            If SheetExists(rngLoop.Value) Then
            Application.DisplayAlerts = False
                wb.Sheets(rngLoop.Value).Delete
            Application.DisplayAlerts = True
            Else
             GoTo nxtRng
            End If
nxtRng:
        Next
        .Activate
    End With
   
    Application.ScreenUpdating = True
End Sub

Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    SheetExists = Not sht Is Nothing
End Function
 

HaHoBe

Active Member
Joined
Jan 24, 2003
Messages
497
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Hi,

working on pictures isn´t the best way to find out if a code will match what is needed.

If you really have different distances as well as dimensions maybe you think about using an array to hold information about the starting row, the numbe of rows as well as the columns to be passed for a loop.

Ciao,
Holger
 

rahildhody

New Member
Joined
Aug 4, 2016
Messages
28
I'm not a 100% sure on how to use arrays to hold information and then paste accordingly.

Would you be able to assist me with that?

I'm unfortunately not able to upload the workbook in this forum, hence have to rely on images to explain the requirements :(
 

HaHoBe

Active Member
Joined
Jan 24, 2003
Messages
497
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Hi,

I´m with you. Thinking about how many components must be nede to insert into an array I think it may be a better way to insert an extra worksheet which would hold the information about the ranges to copy as well as the column to copy it to. The sheet may llok like this:
Mappe2
ABC
1Template rangeTarget columnTarget row
2B84:E87B3
3O84:BV87F3
4B109:E112BNextRow
5O109:BV112FNextRow
6B119:E122BNextRow
7O119:BV122FNextRow
Copy Information

The code to display the information in the immediate window would look like this:
VBA Code:
Dim lngCounter As Long
Dim NextRow As Long
Dim wsTarg As Worksheet
Dim varArray As Variant

Set wsTemp = Worksheets("Template")
Set wsTarg = Worksheets("Output")

With Sheets("Copy Information")
  For lngCounter = 2 To .Range("A" & Rows.Count).End(xlUp).Row
    Debug.Print "Copy from " & Range("A" & lngCounter).Value
    If .Range("C" & lngCounter).Value = "NextRow" Then
      NextRow = wsTarg.Range("B" & .Rows.Count).End(xlUp).Row + 1
      Debug.Print "Copy to " & .Cells(NextRow, .Range("B" & lngCounter).Value).Address
    Else
      Debug.Print "Copy to " & .Cells(.Range("C" & lngCounter).Value, .Range("B" & lngCounter).Value).Address
    End If
  Next lngCounter
End With
Ciao,
Holger
 

rahildhody

New Member
Joined
Aug 4, 2016
Messages
28
omg! thank you so much. I can work with this and can change my approach around slightly. this works brilliantly!

Really appreciate your help :)
 

HaHoBe

Active Member
Joined
Jan 24, 2003
Messages
497
Office Version
  1. 2013
Platform
  1. Windows
Hi rahildhody,

glad I could be of some help in finding a way to solve the problem. Thanks for the feedback.

Ciao,
Holger
 

Forum statistics

Threads
1,144,232
Messages
5,723,148
Members
422,479
Latest member
Mr_Confused

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