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
Windows 10Excel 2019In 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 blankThe 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 Read More