My VBA copies row if cell NOTBLANK but I need target columns in specific order (Code in post)

[Kenneth Green]

Windows 10
Excel 2019

In a workbook, I have two worksheets, "Track Data" and "Titles Data".

In worksheet "Track Data"...
Columns A:J will always have data on each row and Column K may have data in some cells or will be blank

The code below looks at, and down, "Track Data" Column K and where it finds a cell WITH data, it copies Columns A. B, F, G, I, J, K and H to worksheet "Titles Data", then moves on and does that same for every Cell in "K" that has data.

My issue is that I need the data it copies to "Track Data" to be placed in a specific order of Columns.

Like this.

Track Data			Titles Data 
Col. A		to		Col. A
Col. B		to		Col. B
Col. I		to		Col. C
Col. J		to		Col. D
Col. K		to		Col. E
Col. F		to		Col. F
Col. G		to		Col. G
Col. H		to		Col. H

The code is not mine, I found it on a different site while searching for a way to copy the rows but I have adapted it as best I can to suit my needs.

As this code replaces 1000s of rows of forumulas being entered by VBA and copied down (very slow), this code does the same task but with using formulas.

If there is a better (faster) way of doing this I would also be grateful for any suggestions.

Thank you in advance.

Option Explicit
Sub CopyRowsWithData()

Dim erow As Long, lastrow As Long, i As Long
Dim RngCopy As Range

Application.CutCopyMode = True

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableAnimations = False
    End With


With Worksheets("Track Data")
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row

    For i = 2 To lastrow
        If Trim(.Cells(i, "K").Value) <> "" Then
            Set RngCopy = Application.Union(.Range("A" & i), .Range("B" & i), .Range("I" & i), .Range("J" & i), .Range("K" & i), .Range("F" & i), .Range("G" & i), .Range("H" & i))
            RngCopy.Copy ' copy the Union range

            ' get next empty row in "Sheet2"
            erow = Worksheets("Titles Data").Cells(Worksheets("Titles Data").Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            ' paste in the next empty row
            Worksheets("Titles Data").Range("A" & erow).PasteSpecial xlPasteAll
        End If
    Next i
End With

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableAnimations = True
    End With

Application.CutCopyMode = False

End Sub

[#2]

@Kenneth Green 

To copy the rows with specific columns in a specific order, you can modify the code to copy and paste the columns in the desired sequence. Here is the adjusted code:

Vba Code is untested, please backup your file first.

Option Explicit

Sub CopyRowsWithData()
    Dim erow As Long, lastrow As Long, i As Long
    Dim RngCopy As Range
    Dim wsTrackData As Worksheet
    Dim wsTitlesData As Worksheet
    
    Application.CutCopyMode = True

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableAnimations = False
    End With

    ' Set references to the worksheets
    Set wsTrackData = ThisWorkbook.Worksheets("Track Data")
    Set wsTitlesData = ThisWorkbook.Worksheets("Titles Data")
    
    With wsTrackData
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row

        For i = 2 To lastrow
            If Trim(.Cells(i, "K").Value) <> "" Then
                ' Set the range to copy in the desired order
                Set RngCopy = .Range("A" & i) ' Column A
                Set RngCopy = Union(RngCopy, .Range("B" & i)) ' Column B
                Set RngCopy = Union(RngCopy, .Range("I" & i)) ' Column I
                Set RngCopy = Union(RngCopy, .Range("J" & i)) ' Column J
                Set RngCopy = Union(RngCopy, .Range("K" & i)) ' Column K
                Set RngCopy = Union(RngCopy, .Range("F" & i)) ' Column F
                Set RngCopy = Union(RngCopy, .Range("G" & i)) ' Column G
                Set RngCopy = Union(RngCopy, .Range("H" & i)) ' Column H
                
                RngCopy.Copy ' Copy the Union range
                
                ' Get the next empty row in "Titles Data"
                erow = wsTitlesData.Cells(wsTitlesData.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                
                ' Paste in the next empty row, starting from column A
                wsTitlesData.Cells(erow, 1).PasteSpecial xlPasteAll
            End If
        Next i
    End With

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableAnimations = True
    End With

    Application.CutCopyMode = False
End Sub

This code snippet ensures that the columns are copied and pasted in the desired order specified in your example. Adjustments were made to the range assignment and the paste location to align with the desired column order in the "Titles Data" worksheet. The text and steps were edited with the help of AI.

My answers are voluntary and without guarantee!

Hope this will help you.

Was the answer useful? Mark as best response and Like it!

This will help all forum participants.

[#3]

Hi NikolinoDE.

Thank you for your suggestion but it just copies the data in the same column order as the source sheet.

I actually tried setting the target order in much the same way in my code example but that does not work.

As a side note, I find that AI generated VBA code does not work as there are too many things to be considered and some forums do not allow the use of AI when answering questions.
Can't beat real world experience of experts.

[#4]

@Kenneth Green If speed and efficiency is what you're looking for, Advanced Filter might be the solution...

Advanced Filter can be used to filter non-blank cells for a given column and copy the results to a new location, outputting only the columns you want to be returned, in whatever order you choose. Since the end result for your described scenario is to append the filtered data to another worksheet, an intermediary worksheet is required, as Advanced Filter cannot append its results directly to an existing dataset. The code for this is minimal, though, and allows you to copy the filtered results in one shot, rather than looping through each row individually.

The setup for the intermediary worksheet would be as follows:

• insert a new worksheet and rename it "AdvFilter"
• in cell A1, input the column header for column K, exactly as it appears in your "Track Data" worksheet
• in cell A2, type the not equal to operator, <>
• in row 5, starting in column A, type the column headers for each of the columns you want to be included in the filtered results, in the order you want them to be returned (again, make sure they are exactly the same as the column headers used in the source table)

The setup should look something like this (change the header labels to match the actual column labels used in the "Track Data" worksheet):

Advanced Filter Setup

Range A1:A2 is the [CriteriaRange], and range A5:H5 is the [CopyToRange]. The code to run Advanced Filter and append the results to the "Titles Data" worksheet would look something like this:

Option Explicit

Sub CopyRowsWithData()

    On Error GoTo ErrorHandler

'Turn off application settings
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

'Filter the source data to an intermediary worksheet
    Dim wsSource As Worksheet, wsFilter As Worksheet
    Set wsSource = Sheets("Track Data")
    Set wsFilter = Sheets("AdvFilter")
    Call AdvFilter(wsSource.Range("A1").CurrentRegion, wsFilter.Range("A1").CurrentRegion, wsFilter.Range("A5"))

'Copy the results to an array
    Dim rgResults As Range, n As Long
    Set rgResults = wsFilter.Range("A5").CurrentRegion
    n = rgResults.Rows.Count - 1
    If n < 1 Then GoTo CleanUp
    Dim arr As Variant
    arr = rgResults.Offset(1).Resize(n).Value

'Write the results to the destination worksheet
    Dim wsOutput As Worksheet
    Set wsOutput = Sheets("Titles Data")
    n = wsOutput.Cells(wsOutput.Rows.Count, 1).End(xlUp).Row + 1
    wsOutput.Cells(n, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

CleanUp:

'Turn on application settings
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    MsgBox Err.Description, vbExclamation, "Runtime Error: " & Err.Number
    Err.Clear
    GoTo CleanUp

End Sub

Private Sub AdvFilter(sourceRng As Range, criteriaRng As Range, outputRng As Range, Optional optUnique As Boolean)
    
'Clear the previous search results
    outputRng.CurrentRegion.Offset(1).ClearContents

'Output the new search results
    On Error Resume Next
    sourceRng.AdvancedFilter xlFilterCopy, criteriaRng, outputRng.CurrentRegion, optUnique

End Sub

This is just an example, and the above code can be easily adapted for a wide variety of scenarios. For more information on Advanced Filter in VBA, check out: https://excelmacromastery.com/vba-advanced-filter/ 

[#5]

@djclements Thank you for taking the time to write and explain this code which I really do appreciate.

It is so much faster than other code I have tried and I do mean fast.
To filter 41000 rows of data in the Tracks Data worksheet, it took less that a second.

There is an interesting thing happening that I have spent the last couple of hours trying to cure but with out any success.

I set up the AdvFilter sheet exactly as you described but when I use the criteria "<>" it does not filter the results at all and just copies everything first to the AdvFilter sheet and then in to the Titles data sheet.

It does not clear the data it had copied in to AdvFilter which almost doubles the size of the Excel file.

If I was to use something that I know will appear in Column K as the filter "M+S" it filters that perfectly, the for several other text that I know will be in that column.

It just will not filter it using <> which is strange because it should.

[#6 · Accepted solution]

@Kenneth Green The <> operator on its own will only work if the cells in column K are truly blank. Since it's not working for you, I'm guessing the cells contain zero-length strings, most likely the result of a formula returning "". In this case, you can try using a formula as the criteria. There are 3 rules when using formulas in the criteria range:

1. No heading (or use a custom heading not found in the data range, ie: "Criteria1").
2. The formula must result in True or False.
3. The formula should reference the first row of the data range.

So, in the "AdvFilter" worksheet, delete the heading in cell A1 (or use Criteria1 as the heading), then try either one of the following formulas in cell A2:

='Track Data'!K2<>""

//OR

=TRIM('Track Data'!K2)<>""

//OR

=LEN('Track Data'!K2)>0

Formula Criteria Example

To address the Advanced Filter results lingering afterwards, which can significantly increase the size of the file when dealing with large amounts of data, just add one line of code to clear the results (rgResults.Offset(1).ClearContents), immediately after the line of code that copies the results to an array:

'Copy the results to an array
    Dim rgResults As Range, n As Long
    Set rgResults = wsFilter.Range("A5").CurrentRegion
    n = rgResults.Rows.Count - 1
    If n < 1 Then GoTo CleanUp
    Dim arr As Variant
    arr = rgResults.Offset(1).Resize(n).Value
    rgResults.Offset(1).ClearContents

If you have any other questions, let me know. Cheers!

[#7]

Thank you everyone for all of your kind replies and I do appreciate them all.

@djclements you were correct and where formulas that were returning blank, Excel had inserted an apostrophe in those cells.

I cured this by having a line of VBA that removes them.

Thank you for this tip.

[#8]

@Kenneth Green 

Bad luck about the Excel 2019 bit!  A later version and a worksheet formula would do the job.

= LET(
    filtered, VSTACK(header, FILTER(table, Col.H<>"")),
    DROP(SORTBY(filtered, {1,2,10,11,6,7,8,9,3,4,5}),,-2)
  )