Jump to content

Help writing up a macro to copy incrementing selections of values from one sheet to another.

Go to solution Solved by Avocado Diaboli,

I think this should work for that.

 

Sub Consolidate_Data()
    
    Application.ScreenUpdating = False
    
    'Create a copy of the data sheet for manipulation
    ThisWorkbook.Sheets("RawExport").Copy Before:=ThisWorkbook.Sheets("RawExport")
    
    Dim dataSheet As Worksheet
    Set dataSheet = ThisWorkbook.Sheets(1)
    dataSheet.Name = "Result"
    dataSheet.Activate
    
    Const columnOffset As Long = 38
    
    'Create a range and set it to the first cell of the second block of columns
    Dim rng As Range
    Set rng = dataSheet.Range("A2").Offset(, columnOffset)
    
    
    While Not rng.Value = ""
        
        'Resize the range to include the 38 columns as well as all the rows that have values in them
        rng.Resize(rng.End(xlDown).Row - 1, columnOffset).Copy
        
        'Copy the data, then select the first empty row in column A and paste the copied values
        dataSheet.Range("A1").End(xlDown).Offset(1).PasteSpecial
        
        'Offset the range by 38 columns
        Set rng = rng.Offset(, columnOffset)
        
    Wend
    
    
    'Delete all columns except for the leftmost 38
    dataSheet.Range("AM:XFD").Delete
    
    Application.Goto Reference:=dataSheet.Range("A1"), Scroll:=True
    Application.ScreenUpdating = True
    
End Sub

 

I am trying to write a vba loop in excel that copies a selection of cells that contain values from one sheet and then pastes those values into another sheet.

Each time the loop will then need to increment the selection by 38 columns towards the right of the last selection, so the first selection would be column A thru column AL, then the second selection would be column AM thru column BX, and so on.

The selection will need to start at row 2 thru to the last row that contains a value in the second column being selected. Then the next selection will then need to start after the row number that had just had the last of the previous selection's values pasted.

 

I tried to write up a sudo script that hopefully conveys what I am trying to attempt to do, I'm sure alot of the function formatting is incorrect yet clear in what I am wanting to do.

 

Thanks.

 

SUDO SCRIPT EXAMPLE

i=1
j=38
k=2
SET Length=LEN(ColumnID(j)) 'as numeric counted value. Stop counting rows in column once no value found
Sheet1.COPY SELECTION LEN(Row(2(ColumnID(i))) thru LEN(Row(2(ColumnID(j))) Sheet2.PASTE SELECTION Start PASTE at RowID(k) End PASTE at RowID(Length) 'COPY SELECTION should ignore first row entirely
i = 1 + j
j = j + 38
k = k + Length
Loop

Link to comment
Share on other sites

Link to post
Share on other sites

Am I understanding it correctly that your data is laid out in blocks that are situated diagonally and you just want to move over every block all the way to the left?

And now a word from our sponsor: 💩

-.-. --- --- .-.. --..-- / -.-- --- ..- / -.- -. --- .-- / -- --- .-. ... . / -.-. --- -.. .

ᑐᑌᑐᑢ

Spoiler

    ▄██████                                                      ▄██▀

  ▄█▀   ███                                                      ██

▄██     ███                                                      ██

███   ▄████  ▄█▀  ▀██▄    ▄████▄     ▄████▄     ▄████▄     ▄████▄██   ▄████▄

███████████ ███     ███ ▄██▀ ▀███▄ ▄██▀ ▀███▄ ▄██▀ ▀███▄ ▄██▀ ▀████ ▄██▀ ▀███▄

████▀   ███ ▀██▄   ▄██▀ ███    ███ ███        ███    ███ ███    ███ ███    ███

 ██▄    ███ ▄ ▀██▄██▀    ███▄ ▄██   ███▄ ▄██   ███▄ ▄███  ███▄ ▄███▄ ███▄ ▄██

  ▀█▄    ▀█ ██▄ ▀█▀     ▄ ▀████▀     ▀████▀     ▀████▀▀██▄ ▀████▀▀██▄ ▀████▀

       ▄█ ▄▄      ▄█▄  █▀            █▄                   ▄██  ▄▀

       ▀  ██      ███                ██                    ▄█

          ██      ███   ▄   ▄████▄   ██▄████▄     ▄████▄   ██   ▄

          ██      ███ ▄██ ▄██▀ ▀███▄ ███▀ ▀███▄ ▄██▀ ▀███▄ ██ ▄██

          ██     ███▀  ▄█ ███    ███ ███    ███ ███    ███ ██  ▄█

        █▄██  ▄▄██▀    ██  ███▄ ▄███▄ ███▄ ▄██   ███▄ ▄██  ██  ██

        ▀███████▀    ▄████▄ ▀████▀▀██▄ ▀████▀     ▀████▀ ▄█████████▄

 

Link to comment
Share on other sites

Link to post
Share on other sites

All data is listed in a 38-column table, with header names that are reused throughout the entire worksheet. I want to consolidate all data into each appropriate column header that they are listed under.

 

The process flow:

Select cells from first 38 columns in SHEET1. Example: A2:AL(last row that contains data in column; not blank)

Copy selection to A2 in SHEET2 or next blank row in A:A in SHEET2.

Loop through and select/copy the next 38-column increment in SHEET1 and paste to next blank row in A:A in SHEET2 until there are no more columns or until a column is blank.

 

I was given approval to also export the data sheet I am working from.

DataExport.xlsx

Link to comment
Share on other sites

Link to post
Share on other sites

I think this should work for that.

 

Sub Consolidate_Data()
    
    Application.ScreenUpdating = False
    
    'Create a copy of the data sheet for manipulation
    ThisWorkbook.Sheets("RawExport").Copy Before:=ThisWorkbook.Sheets("RawExport")
    
    Dim dataSheet As Worksheet
    Set dataSheet = ThisWorkbook.Sheets(1)
    dataSheet.Name = "Result"
    dataSheet.Activate
    
    Const columnOffset As Long = 38
    
    'Create a range and set it to the first cell of the second block of columns
    Dim rng As Range
    Set rng = dataSheet.Range("A2").Offset(, columnOffset)
    
    
    While Not rng.Value = ""
        
        'Resize the range to include the 38 columns as well as all the rows that have values in them
        rng.Resize(rng.End(xlDown).Row - 1, columnOffset).Copy
        
        'Copy the data, then select the first empty row in column A and paste the copied values
        dataSheet.Range("A1").End(xlDown).Offset(1).PasteSpecial
        
        'Offset the range by 38 columns
        Set rng = rng.Offset(, columnOffset)
        
    Wend
    
    
    'Delete all columns except for the leftmost 38
    dataSheet.Range("AM:XFD").Delete
    
    Application.Goto Reference:=dataSheet.Range("A1"), Scroll:=True
    Application.ScreenUpdating = True
    
End Sub

 

And now a word from our sponsor: 💩

-.-. --- --- .-.. --..-- / -.-- --- ..- / -.- -. --- .-- / -- --- .-. ... . / -.-. --- -.. .

ᑐᑌᑐᑢ

Spoiler

    ▄██████                                                      ▄██▀

  ▄█▀   ███                                                      ██

▄██     ███                                                      ██

███   ▄████  ▄█▀  ▀██▄    ▄████▄     ▄████▄     ▄████▄     ▄████▄██   ▄████▄

███████████ ███     ███ ▄██▀ ▀███▄ ▄██▀ ▀███▄ ▄██▀ ▀███▄ ▄██▀ ▀████ ▄██▀ ▀███▄

████▀   ███ ▀██▄   ▄██▀ ███    ███ ███        ███    ███ ███    ███ ███    ███

 ██▄    ███ ▄ ▀██▄██▀    ███▄ ▄██   ███▄ ▄██   ███▄ ▄███  ███▄ ▄███▄ ███▄ ▄██

  ▀█▄    ▀█ ██▄ ▀█▀     ▄ ▀████▀     ▀████▀     ▀████▀▀██▄ ▀████▀▀██▄ ▀████▀

       ▄█ ▄▄      ▄█▄  █▀            █▄                   ▄██  ▄▀

       ▀  ██      ███                ██                    ▄█

          ██      ███   ▄   ▄████▄   ██▄████▄     ▄████▄   ██   ▄

          ██      ███ ▄██ ▄██▀ ▀███▄ ███▀ ▀███▄ ▄██▀ ▀███▄ ██ ▄██

          ██     ███▀  ▄█ ███    ███ ███    ███ ███    ███ ██  ▄█

        █▄██  ▄▄██▀    ██  ███▄ ▄███▄ ███▄ ▄██   ███▄ ▄██  ██  ██

        ▀███████▀    ▄████▄ ▀████▀▀██▄ ▀████▀     ▀████▀ ▄█████████▄

 

Link to comment
Share on other sites

Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now

×