VBA- copy and paste offset range of data with specific text to sheet 2, repeat copy and paste loop to offset below first pasted data range

A

Aisling3475

New Member
Joined
Mar 21, 2022
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Hi There, I have reached the limit of my VBA macro knowledge and am in a bit of a pickle! I have a data report that contains data across a range of dates in a worksheet Sheet 1. I need to generate a macro to execute the following commands:
1. Find specific wording in Sheet1 "esWeeklyCal" in Column B
2. Resize this to select data range 14 rows down and 37 columns to the right (column AI).
3. Copy this range
4. Paste this range starting in Cell B2 in Sheet 2.
5. Then I want the code to go back to sheet 1 and find the next "esWeeklyCal" data range in Sheet 1 and copy this to sheet 2 below the first data range copied in Step 4 above and repeat this for all data ranges for 'esweeklyCal'.

The code below is what I have built so far for this. The problem is every time I execute this the first data range copies to Sheet 2 at cell B2, then subsequent data ranges paste over the second data range in cell B16 and therefore I lose these data ranges in the macro. Some extra info for that may or may not help:
- Sheet 1 has multiple 'esWeeklyCal' rows and associated data ranges. Between these data ranges are other data that I do not want.
- The 'esWeeklyCal' data range has 'esweeklyCal' in first column (call this column B) and the data of interest is 33 columns to the right (column AI) and there is 14 rows of data in that column. The rows below the 'esweeklyCal' text in column B are empty. So when I paste to Sheet 2 I have 'esweeklyCal' in Column B and the 13 rows of data in Column AI. I need to keep all of the 'metadata' in between column B and column AI to the row 13.
- The data report in sheet 1 is in merged cells in some places, is this an issue for the code, should I use paste special for values only?

So I cannot seem to get the code to loop back to Sheet 1 after first paste event, select the next data range, copy and paste and offset from the first paste event in Sheet 2 to retain all data. I need it to repeat the text search in sheet 1 and repeat the paste to pull all data ranges for 'esweeklyCal' into Sheet 2.

***MACRO CODE****
Sub ExtractData()

Dim StatusCol As Range
Dim Status As Range
Dim PasteCell As Range

Set StatusCol = Sheet1.Range("A9:AK10000")

For Each Status In StatusCol

If Sheet2.Range("B2") = "" Then
Set PasteCell = Sheet2.Range("B2")
Else
Set PasteCell = Sheet2.Range("B1").End(xlDown).Offset(14, 0)
End If

If Status = "esWeeklyCal" Then Status.Offset(0, 0).Resize(14, 37).Copy PasteCell

Next Status

For Each Status In StatusCol

If Sheet2.Range("B16") = "" Then
Set PasteCell = Sheet2.Range("B16")
Else
Set PasteCell = Sheet2.Range("B15").End(xlDown).Offset(14, 0)
End If

If Status = "esWeeklyCal" Then Status.Offset(0, 0).Resize(14, 37).Copy PasteCell

Next Status

End Sub
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
Hi, you were close, just needed to get a loop to the next blank row going. Try the below:

VBA Code: 
Option Explicit
Sub ExtractData()

    Dim StatusCol As Range
    Dim Status As Range
    Dim PasteCell As Long
    Set StatusCol = Sheet1.Range("A9:AK10000")
    
    PasteCell = Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row + 1  'Finds the lastrow and use next blankrow
    
    For Each Status In StatusCol
        If Status = "esWeeklyCal" Then
            Status.Offset(0, 0).Resize(14, 37).Copy Sheets("Sheet2").Range("B" & PasteCell) 'Paste to blankrow on Sheet2
            PasteCell = Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row + 1  'Find the next blankrow again
        End If
    Next Status
   
End Sub
 

Attachments

  • forExtractData.jpg
    forExtractData.jpg
    227.3 KB · Views: 41
Upvote 0
Thanks very much for your help here, DacEasy. I tried your code but got some errors. I am not sure but suspect it's down to how my report data sheet is compiled which I cannot change. See attachment for the 'Report Data' sheet. The cells below the 'esWeeklyCal' are blank which might cause issues for the code. The data range in red brackets is what I want to copy to sheet 2 (columns D and H are just shown for illustration in the attachment, these will need to be columns AE and AI in code when I eventually crack it!), using the specific term 'esWeeklyCal' and resize/offset functions. When I run my original code above it only pastes first and last data range. Using your code above is giving me 'Subscript out of range' errors . I'm not sure how to account for this. Any more suggestions are greatly appreciated as this is something I have been struggling with for some time!
 

Attachments

  • Report Data for Macro.JPG
    Report Data for Macro.JPG
    83.2 KB · Views: 31
Upvote 0
Ok from the picture of the data, your last row needs to be based on column H.

VBA Code: 
Option Explicit
Sub ExtractData()

    Dim StatusCol As Range
    Dim Status As Range
    Dim PasteCell As Long
    Set StatusCol = Sheet1.Range("A9:AK10000")
    
    PasteCell = Sheets("Sheet2").Cells(Rows.Count, "H").End(xlUp).Row + 1  'Finds the lastrow and use next blankrow
    
    For Each Status In StatusCol
        If Status = "esWeeklyCal" Then
            Status.Offset(0, 0).Resize(14, 37).Copy Sheets("Sheet2").Range("B" & PasteCell) 'Paste to blankrow on Sheet2
            PasteCell = Sheets("Sheet2").Cells(Rows.Count, "H").End(xlUp).Row + 1  'Find the next blankrow again
        End If
    Next Status
   
End Sub
 
Upvote 0
DacEasy said:
Ok from the picture of the data, your last row needs to be based on column H.

VBA Code: 
Option Explicit
Sub ExtractData()

    Dim StatusCol As Range
    Dim Status As Range
    Dim PasteCell As Long
    Set StatusCol = Sheet1.Range("A9:AK10000")
   
    PasteCell = Sheets("Sheet2").Cells(Rows.Count, "H").End(xlUp).Row + 1  'Finds the lastrow and use next blankrow
   
    For Each Status In StatusCol
        If Status = "esWeeklyCal" Then
            Status.Offset(0, 0).Resize(14, 37).Copy Sheets("Sheet2").Range("B" & PasteCell) 'Paste to blankrow on Sheet2
            PasteCell = Sheets("Sheet2").Cells(Rows.Count, "H").End(xlUp).Row + 1  'Find the next blankrow again
        End If
    Next Status
  
End Sub
Click to expand...
Thanks again DacEasy. The script is returning a range error see below. The line in yellow seems to be causing issue using the data I provided in the screenshot above. Any thoughts?
1649349362674.png
 
Upvote 0
Use Upload Mini-sheet button to upload your data, I will test on my end.
 
Upvote 0
Extract Data Tool Basic.xlsx
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAI
1TaskDateOther Data29Other Data30Other Data31Other Data1Other Data2Other Data3Other Data4Other Data5Other Data6Other Data7Other Data8Other Data9Other Data10Other Data11Other Data12Other Data13Other Data14Other Data15Other Data16Other Data17Other Data18Other Data19Other Data20Other Data21Other Data22Other Data23Other Data28Other Data24Other Data25Other Data26Other Data27Data
2esWeeklyCal01-Jan-22ABAABABABABABABABABABABABAParam1BABAData1
3Param2Data2
4Param3Data3
5Param4Data4
6Param5Data5
7Param6Data6
8Param7Data7
9Param8Data8
10Param9Data9
11Param10Data10
12Param11Data11
13Param12Data12
14Param13Data13
15
16Activity 204-Jan-22ABAABABABABABABABABABABABABBABAData1
17Data2
18Data3
19Data4
20Data5
21
22esWeeklyCal15-Jan-22ABAABABABABABABABABABABABAParam1BABAData1
23Param2Data2
24Param3Data3
25Param4Data4
26Param5Data5
27Param6Data6
28Param7Data7
29Param8Data8
30Param9Data9
31Param10Data10
32Param11Data11
33Param12Data12
34Param13Data13
35
36Activity 204-Jan-22ABAABABABABABABABABABABABABBABAData1
37Data2
38Data3
39Data4
40Data5
41
42esWeeklyCal29-Jan-22ABAABABABABABABABABABABABAParam1BABAData1
43Param2Data2
44Param3Data3
45Param4Data4
46Param5Data5
47Param6Data6
48Param7Data7
49Param8Data8
50Param9Data9
51Param10Data10
52Param11Data11
53Param12Data12
54Param13Data13
55
56Activity 204-Feb-22ABAABABABABABABABABABABABABBABAData1
57Data2
58Data3
59Data4
60Data5
61
62esWeeklyCal12-Feb-22ABAABABABABABABABABABABABAParam1BABAData1
63Param2Data2
64Param3Data3
65Param4Data4
66Param5Data5
67Param6Data6
68Param7Data7
69Param8Data8
70Param9Data9
71Param10Data10
72Param11Data11
73Param12Data12
74Param13Data13
Report Data
 
Upvote 0
Oh my Sheet Name is Sheet2 what is the name of your Sheets?
 
Upvote 0
Recreate what you are trying to do with less columns. Once it's working, then expand.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
How to copy and paste data with values only when a condition is met?
Replies
7
Views
1K
Joe4
Joe4
D
  • Solved
I can only get this VBA code to work if I add a column onto the end of the dataset.
Replies
5
Views
490
kevin9999
K
N
  • Solved
Copying Row to another Worksheet based on multiple criteria.
Replies
1
Views
614
noveske
N
Logit
  • Question Question
Search In Other Workbook - Copy/Paste Offset Data To First Workbook - Repeat Process
Replies
7
Views
328
Logit
Logit
V
  • Question Question
Copy Range from Multiple Sheets and Paste Link into a Single Sheet
Replies
2
Views
182
vbascientist
V

Forum statistics

Threads
1,223,911
Messages
6,175,327
Members
452,635
Latest member
laura12345

Share this page

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
Back
Top