CODEWITHSUNDEEP
vbaexcelexcel-2016
Martin Hewitt Tayler
Martin Hewitt Tayler

Reputation: 67

Find last three cells in a row cut and paste to last three columns excel vba

My client has copied data from a .pdf file by highlighting it and pasting into a worksheet (the converter in Acrobat does not work well). This means the values in the last three cells of each row are staggered across the columns. This means the client has to select the cells from each row and cut and paste into new columns.

I looked at a way to do this but wracked my brain before I stumbled across Bruce Wayne's code which moves the last cell of each row to the end column:

Sub move_data()
Dim LastRow As Long, lastCol As Long
Dim ws As Worksheet

Set ws = Worksheets("Sheet1")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
lastCol = ws.UsedRange.Columns.Count

Cells.EntireColumn.AutoFit

Dim i As Long
For i = 1 To LastRow
    If ws.Cells(i, lastCol) = "" Then
       ws.Cells(i, ws.Cells(i, 1).End(xlToRight).Column).Cut
       ws.Cells(i,lastCol)               
   End If
Next i

End Sub

So, that is exactly what I wanted but also the 2 cells to the left of last cell on that row. Could someone help me with the syntax on how to achieve this last bit.

NB. Running the macro makes Excel 2016 work very hard looping through the worksheet, which only has less than 100 rows. Any ideas on why the performance is slow?

EDITED Post

To show a representation of the worksheet following execution of the replacement code here is a screenshot of my data:

enter image description here

The data in the three columns to the right come from values in furthest 3 cells of each column however, as you can see in row 18 the code did not work. Any clues to why would be useful.

Upvotes: 0

Views: 383

Answers (1)

ProfoundlyOblivious
ProfoundlyOblivious

Reputation: 1485

I tried reading through your code but wasn't very successful. It seems clear that you're trying to loop from the top down with:

For i = 1 To LastRow
    If ws.Cells(i, lastCol) = "" Then
       ws.Cells(i, ws.Cells(i, 1).End(xlToRight).Column).Cut
       ws.Cells(i,lastCol)               
   End If
Next i

But you're not evaluating the row deep enough to identify the last three cells, you're not actually moving any data, and I think you'll throw an error on your first iteration.

It looks like you're trying to do this the "easy" way nested For loops and the slowness you reported almost confirms it. Nested For loops are fast and easy to write but they can take a long time to run if you're selecting or changing thousands of cells. You can boost the speed process by minimizing the number of cells you activate/change and turning screen updating off.

The code below should work if pasted into a fresh module. I tried to follow the same logic as your example but deviated a bit. 

 Sub move_data()
    Dim LastRow As Long, LastCol As Long, LastCell As Long
    Dim ws As Worksheet
    Dim ColLimit as Integer
    Dim i As Integer, j As Integer

    Application.ScreenUpdating = False

    Set ws = ActiveSheet
    ColLimit = 2    ' [0 through 2] = 3, # of columns to populate
    LastRow = ws.UsedRange.Rows.Count
    LastCol = ws.UsedRange.Columns.Count
    Cells.EntireColumn.AutoFit

    For i = 1 To LastRow
       LastCell = LastCol
        For j = 0 To ColLimit
            LastCell = ws.Cells(i, LastCol - j).End(xlToLeft).Column
            If LastCell > 0 And ws.Cells(i, LastCol - j) = "" Then
                LastCell = ws.Cells(i, LastCol - j).End(xlToLeft).Column
                ws.Cells(i, LastCell).Copy ws.Cells(i, LastCol - j)
                ws.Cells(i, LastCell) = ""
            End If
       Next j
    Next i

    Application.ScreenUpdating = True

    End Sub

` If speed is an issue then you should step away from these loops and work with arrays and ranges. They are significantly faster.

For giggles, this is how it can be done manually in about 30 seconds and there's probably an easier way that I haven't seen yet!

Highlight the data range
Ribbon, Data tab, From Table/Range (opens query editor)
Ribbon, Transform tab, Transpose
Ribbon, Transform tab, Reverse Rows
File, Close and load, to worksheet
Highlight the data range
Ribbon, Design, Convert to Range
Goto Blanks (Ctrl G - Special - Blanks)
Delete blanks - Move Cells up (Alt E, D)

Now top rows have the all the values that would be in your columns. If you want them in columns but don't care if the columns are reversed you can Copy and Paste Special Transform.

But if you want those exact same columns:

Highlight the data range
Ribbon, Data tab, From Table/Range (opens query editor)
Ribbon, Transform tab, Reverse Rows
Ribbon, Transform tab, Transpose
File, Close and load, to worksheet

Now your columns are on the right. Of course Power Query can be coded in VBA but I haven't tackled that yet.

Upvotes: 0

Related Questions