Help with Repeating until Last Row

A

abigalileo

New Member
Joined
Apr 26, 2015
Messages
3
Hi, I'm new to VBA and I'm having trouble trying to write a looping macro.

This is what I'm trying to repeat:

ActiveCell.Offset(1, 0).Range("A1:B1").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(-1, 0).Range("A1:C1").Select
Selection.Cut
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(-1, 0).Rows("1:1").EntireRow.Select
Selection.Delete Shift:=xlUp
ActiveCell.Offset(1, 0).Rows("1:6").EntireRow.Select
Selection.Delete Shift:=xlUp

I want it to repeat until it reaches the last row in the sheet. I've tried just about everything I could find through Google for the whole day and nothing is working. I can't do the thing where it stops when it reaches an empty cell since the data is discontinuous (though repetitively so).

Any help would be very, very appreciated.
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Sort by date Sort by votes
Welcome to the Forum!

It's not immediately obvious from this code what you are trying to do.

Can you post a screenshot of what your data looks like to start with, and how you'd like it to look after your macro runs?
 
Upvote 0
StephenCrump said:
Welcome to the Forum!

It's not immediately obvious from this code what you are trying to do.

Can you post a screenshot of what your data looks like to start with, and how you'd like it to look after your macro runs?
Click to expand...

Oh yeah sure okay so here's what it looks like now:

2mdoxw4.jpg


It's a pretty terrible data file that's generated by a very old program. Essentially, these are people's response times on a game. For some reason, when the program records the game data and writes this excel file, the data gets "dislocated" so everything from the fourth column onwards gets pushed underneath on a second line for each set of responses. What I'm trying to do is to correct that by pasting the data into its correct place.

In addition, there is a lot of superfluous data in there that I don't need, and wish to get rid of.

Simple, but tedious to do 10000 times, so I thought it would be a good idea to try and make a macro for it. Also, ideally, I would want this macro to be able to run on any other data file the program would churn out with a different number of recorded response times.

This is what I would like ten rows of cleaned up data to look like:
2mowpjk.jpg

(This is cut short so you don't see all the way to AZ like in the first picture but essentially I now have one line of data per person)

What I did in the code I pasted previously was to insert two extra cells on the front of the second row, paste the three cells from the first row into the three new empty spaces on the second row, and then delete the now empty first row. I then also deleted the 6 rows separating this row of data from the next person's data since I didn't need that information. (I hope that makes sense?)
 
Upvote 0
Here's one way you might do it (please test on a backup copy of your data):

Code: 
Sub Rearrange()

    Dim vDataOld As Variant, vDataNew As Variant
    Dim lRows As Long, lCols As Long
    Dim r As Long, c As Long, lCount As Long
    Const START_ROW = 2, EXTRA_COLS = 3, BLANK_COLS = 1
    
    'Get rid of junk rows
    With Range("B" & START_ROW & ":B" & Range("B" & Rows.Count).End(xlUp).Row)
        .Replace "", "#N/A", xlWhole
        On Error Resume Next
        .SpecialCells(xlConstants, xlErrors).EntireRow.Delete
        On Error GoTo 0
    End With

    'Get data in remaining rows
    With Range("A" & START_ROW & ":Z" & Range("C" & Rows.Count).End(xlUp).Row)  'Is Z the last col?
        vDataOld = .Value
        .ClearContents
    End With
    lRows = UBound(vDataOld)
    lCols = UBound(vDataOld, 2)
    ReDim vDataNew(1 To lRows, 1 To lCols + EXTRA_COLS)
    
    'Re-order data
    For r = 1 To lRows Step 2
        lCount = lCount + 1
        For c = 1 To EXTRA_COLS
            vDataNew(lCount, c) = vDataOld(r, c)
        Next c
        For c = 1 To lCols - BLANK_COLS
            vDataNew(lCount, c + EXTRA_COLS) = vDataOld(r + 1, c + BLANK_COLS)
        Next c
    Next r
    Range("A" & START_ROW).Resize(lRows, lCols + EXTRA_COLS).Value = vDataNew
    
End Sub
As written, it will convert this:

Excel 2010
ABCDEFGHIJKL
HeadersHeadersHeadersHeaders

<tbody>
[TD="align: center"]1[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]2[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]3[/TD]
[TD="align: right"][/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]11[/TD]
[TD="align: right"]12[/TD]
[TD="align: right"]13[/TD]
[TD="align: right"]14[/TD]

[TD="align: center"]4[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"]junk[/TD]
[TD="align: right"]junk[/TD]

[TD="align: center"]5[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"]junk[/TD]
[TD="align: right"]junk[/TD]

[TD="align: center"]6[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"]junk[/TD]
[TD="align: right"]junk[/TD]

[TD="align: center"]7[/TD]
[TD="align: right"]21[/TD]
[TD="align: right"]22[/TD]
[TD="align: right"]23[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]8[/TD]
[TD="align: right"][/TD]
[TD="align: right"]24[/TD]
[TD="align: right"]25[/TD]
[TD="align: right"]26[/TD]
[TD="align: right"]27[/TD]
[TD="align: right"]28[/TD]
[TD="align: right"]29[/TD]
[TD="align: right"]30[/TD]
[TD="align: right"]31[/TD]
[TD="align: right"]32[/TD]
[TD="align: right"]33[/TD]
[TD="align: right"]34[/TD]

[TD="align: center"]9[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"]junk[/TD]
[TD="align: right"]junk[/TD]

[TD="align: center"]10[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"]junk[/TD]
[TD="align: right"]junk[/TD]

[TD="align: center"]11[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"]junk[/TD]
[TD="align: right"]junk[/TD]

</tbody>
1
​

to this:

Excel 2010
ABCDEFGHIJKLMN
HeadersHeadersHeadersHeaders

<tbody>
[TD="align: center"]1[/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]2[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]11[/TD]
[TD="align: right"]12[/TD]
[TD="align: right"]13[/TD]
[TD="align: right"]14[/TD]

[TD="align: center"]3[/TD]
[TD="align: right"]21[/TD]
[TD="align: right"]22[/TD]
[TD="align: right"]23[/TD]
[TD="align: right"]24[/TD]
[TD="align: right"]25[/TD]
[TD="align: right"]26[/TD]
[TD="align: right"]27[/TD]
[TD="align: right"]28[/TD]
[TD="align: right"]29[/TD]
[TD="align: right"]30[/TD]
[TD="align: right"]31[/TD]
[TD="align: right"]32[/TD]
[TD="align: right"]33[/TD]
[TD="align: right"]34[/TD]

</tbody>
1​
 
Upvote 0
Thanks so much, but sorry it doesn’t quite work! :( the first and last sections seem okay except for still having a few lines of the junk data, but the middle portion does something really weird:

6hp5kp.jpg

34xpanp.jpg


:confused:

Oh also, I guess I wasn't clear but the last column is "AZ" so I changed "Z" to "AZ" in the code you provided.
 
Upvote 0
I assume your screenshot is "after", which suggests that rows that appear blank in Column B (and which my code should have deleted) perhaps contain spaces or non-printing characters.

Can you test just this piece of code to see if it correctly deletes junk rows:

Code: 
Sub DeleteRows()

    Const START_ROW = 2
    
    'Get rid of junk rows
    With Range("B" & START_ROW & ":B" & Range("B" & Rows.Count).End(xlUp).Row)
        .Value = Evaluate("IF(ISTEXT(" & .Address & "),CLEAN(TRIM(" & .Address & ")),REPT(" & .Address & ",1))")
        .Replace "", "#N/A", xlWhole
        On Error Resume Next
        .SpecialCells(xlConstants, xlErrors).EntireRow.Delete
        On Error GoTo 0
    End With

End Sub

It's a little hard to see your data format because of the resolution of your screenshot.

Can you please post a small sample of "before" data using MrExcel HTML maker: see post#2 here:
http://www.mrexcel.com/forum/board-announcements/515787-forum-posting-guidelines.html)
or similar, eg Excel Jeanie.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
How To Loop Macro
Replies
6
Views
466
rlv01
R
L
  • Solved
Adding empty lines based on value via “I” loop which crashes and lags
2
Replies
10
Views
383
Joe4
Joe4
S
  • Question Question
Vba to search for a value in column A, if found enter specific text then delete the row
Replies
2
Views
217
StevenChin
S
R
  • Solved
How to loop a macro
Replies
2
Views
569
rlcurlee
R
Z
  • Solved
Apply 1 macro to all sheets in a workbook: Why is this code not working?
Replies
2
Views
451
ZA_Fella
Z

Forum statistics

Threads
1,223,237
Messages
6,170,924
Members
452,366
Latest member
TePunaBloke

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top