Forum Discussion

Kenneth Green's avatar
Kenneth Green
Brass Contributor
Apr 26, 2024

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

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

 

 

 

  • djclements's avatar
    djclements
    Apr 26, 2024

    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!

  • 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)
      )

     

  • djclements's avatar
    djclements
    Bronze Contributor

    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/ 

    • Kenneth Green's avatar
      Kenneth Green
      Brass Contributor
      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.
      • djclements's avatar
        djclements
        Bronze Contributor

        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!

  • NikolinoDE's avatar
    NikolinoDE
    Gold Contributor

    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.

    • Kenneth Green's avatar
      Kenneth Green
      Brass Contributor
      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.

Resources