Simplify VBA code moving data around spreadsheet

[HanR]

Hello!

I just starting learning VBA to solve this problem. I have data that I need to interpret, but the way it is outputted makes it impossible. I figured out how to use VBA to solve it using this forum, but I am aware it is done about as clunkily as possible (i.e. I use a ton of 'Select' commands and have tons of data on the clipboard). I tried doing it more streamlined, but hit a wall in what I have been able to self-teach. I would love help streamlining what I have done.

I have 500ish lines of data. Each new data set starts at '9999'. The end goal is to find the average of each data set and make a graph. I approached it by getting each row to start with '9999' and then I can do the averaging/graphing easily after that. (I have not created an averaging or graphing macro yet, just the organizing the data.) The way I could figure it out was to get all data onto one long row, then copy the data starting at the next '9999' cell down a row and loop until all of Column A is '9999', with the data after it.

Here is an example of what the data output looks like before running the macro:

Hannah's Excel Copy.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	Address	1	2	3	4	5	6	7	8	9	10
2	DS631	36	36	36	37	36	37	31	8	9999	0
3	DS641	32	41	40	41	41	42	42	43	43	44
4	DS651	44	44	45	45	45	40	10	9999	0	33
5	DS661	37	36	37	37	37	37	37	37	36	36
6	DS671	37	37	37	37	37	27	10	9999	0	34
7	DS681	20	36	39	38	39	39	40	41	42	42
8	DS691	43	42	42	43	43	41	10	9999	0	35
9	DS701	34	38	38	38	39	38	38	39	38	38
10	DS711	38	38	38	38	39	34	7	9999	0	36
11	DS721	41	39	40	40	40	40	40	40	41	42
12	DS731	42	42	42	43	43	42	9	9999	0	37
13	DS741	20	38	37	38	38	38	38	39	39	38
14	DS751	38	39	38	39	39	38	11	11	9999	0
15	DS761	38	37	39	39	40	39	39	39	40	41
16	DS771	41	41	41	42	43	43	42	9	9999	0
17	DS781	39	35	36	36	36	36	36	38	37	36
18	DS791	37	37	36	37	37	37	33	9	9999	0
19	DS801	40	42	41	41	42	43	41	42	43	43
20	DS811	44	44	44	45	46	46	35	32	9999	0
21	DS821	41	37	37	36	36	36	37	37	36	36
22	DS831	36	36	36	36	36	32	11	9999	0	42
23	DS841	34	41	40	40	41	40	42	42	42	43
24	DS851	43	44	44	45	46	38	13	9999	0	43
25	DS861	37	37	37	37	37	37	37	37	37	37
26	DS871	36	37	37	37	31	10	9999	0	44	36
27	DS881	41	39	39	41	40	41	41	42	41	42
28	DS891	42	43	43	44	36	12	9999	0	45	34
29	DS901	37	37	38	37	37	37	37	37	37	37
Sheet2

Here is the code I am using:

Sub OrganizeData()
'   Deletes Header Row
'   Deletes Header Column
'   Copies Range A2:J2
'   Pastes first open cell Row 1
'   Deletes Emptry Row 2
'   Repeates until no data is left
'   Search each row for first instance of 9999 after A2
'   Copy data from that cell to end of line
'   Paste data on next row
'   Repeat until all data is sorted

Rows(1).EntireRow.Delete

Columns(1).EntireColumn.Delete

Do Until IsEmpty("A2:J2")
    Range("A2:J2").Select
    Selection.Cut
    Range("A1").Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(0, 1).Select
    ActiveSheet.Paste
    Rows("2:2").Select
    Selection.Delete Shift:=xlUp
    If IsEmpty(ActiveCell) Then
    Exit Do
    End If
Loop

Range("A1").Select

Do While ActiveCell >= 0
    If ActiveCell >= 0 Then

ActiveCell.End(xlToLeft).Select
ActiveCell.Offset(0, 1).Select

Do Until ActiveCell = 9999
    If ActiveCell = 9999 Then
   
Else
    ActiveCell.Offset(0, 1).Select
End If
    If (IsEmpty(ActiveCell)) Then Exit Do
Loop
    
    Range(ActiveCell, ActiveCell.End(xlToRight)).Select
    Selection.Cut
    ActiveCell.End(xlToLeft).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
Else
    End If
    If (IsEmpty(ActiveCell)) Then Exit Do
Loop

End Sub

I really appreciate any guidance you have! I worry it may crash on large data sets, but it seems to be functioning OK. It just bogs everything down. Thank you in advance!

 

[johnnyL]

This is my first swing at it. It still needs to be improved, but like I said, this is the first phase of improvement, next phase would be to eliminate the remaining selects:

Sub OrganizeDataV1()
'
    Dim RowCounter  As Long
'
    Rows(1).EntireRow.Delete                                            ' Deletes Header Row and shifts cells up
    Columns(1).EntireColumn.Delete                                      ' Deletes Header Column and shifts cells left
'
    Do Until IsEmpty("A2:J2")
        Range("A2:J2").Cut Range("A1").End(xlToRight).Offset(0, 1)      '   Cut Range A2:J2 and paste to first empty cell Row 1
        Rows(2).EntireRow.Delete                                        '   Delete 2nd Row and shift cells up
'
        If Range("A2") = vbNullString Then Exit Do                      '   If Row 2 is empty then exit loop
    Loop                                                                ' If Row 2 is not empty then loop back
'
'
    RowCounter = 1                                                                              ' Initiate our RowCounter
'
    Do While Range("A" & RowCounter) >= 0
        Range("A" & RowCounter).Offset(0, 1).Select                                             ' Bx is selected at this point
'
        Do Until ActiveCell = 9999                                                              ' Search each row for first instance of 9999 after A2
            ActiveCell.Offset(0, 1).Select
'
            If (IsEmpty(ActiveCell)) Then Exit Sub                                              ' If no more data then exit sub
        Loop
'
'       Copy data from that cell to end of line & Paste data on next row down
        Range(ActiveCell, ActiveCell.End(xlToRight)).Cut ActiveCell.End(xlToLeft).Offset(1, 0)
'
        RowCounter = RowCounter + 1                                                             ' Increment our RowCounter
    Loop
End Sub

Let us know how that works so far,

 

[HanR]

Dim RowCounter As Long ' Rows(1).EntireRow.Delete ' Deletes Header Row and shifts cells up Columns(1).EntireColumn.Delete ' Deletes Header Column and shifts cells left ' Do Until IsEmpty("A2:J2") Range("A2:J2").Cut Range("A1").End(xlToRight).Offset(0, 1) ' Cut Range A2:J2 and paste to first empty cell Row 1 Rows(2).EntireRow.Delete ' Delete 2nd Row and shift cells up ' If Range("A2") = vbNullString Then Exit Do ' If Row 2 is empty then exit loop Loop ' If Row 2 is not empty then loop back ' ' RowCounter = 1 ' Initiate our RowCounter ' Do While Range("A" & RowCounter) >= 0 Range("A" & RowCounter).Offset(0, 1).Select ' Bx is selected at this point ' Do Until ActiveCell = 9999 ' Search each row for first instance of 9999 after A2 ActiveCell.Offset(0, 1).Select ' If (IsEmpty(ActiveCell)) Then Exit Sub ' If no more data then exit sub Loop ' ' Copy data from that cell to end of line & Paste data on next row down Range(ActiveCell, ActiveCell.End(xlToRight)).Cut ActiveCell.End(xlToLeft).Offset(1, 0) ' RowCounter = RowCounter + 1 ' Increment our RowCounter Loop End Sub

Thank you so much! The code works perfectly. It was so helpful to see how you wrote some of the copy and paste codes. I couldn't figure out how to offset the paste all in one line, and I can see now what I was doing wrong! I so appreciate your time in streamlining the majority of my code.

As I am new to Macros, is it normal for a code like this to take a minute or two to run and to freeze Excel while processing? I know it is working through a ton of data (500+ lines), so not complaining, just wondering if it needs more optimizing or if that is to be expected.

 

[johnnyL]

Without using Arrays to make it faster ...

Post #1 in this thread = Avg = 3.2265625 for the data that you provided
Post #2 in this thread = Avg = 1.7109375

The following code should Avg about 0.2546875 for the data that you provided:

Sub MyOrganizeDataSpeedUpV2()                                                               ' Avg 0.2546875
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim RowCounter  As Long
'
    Rows(1).EntireRow.Delete                                            ' Deletes Header Row and shifts cells up
    Columns(1).EntireColumn.Delete                                      ' Deletes Header Column and shifts cells left
'
    Do Until IsEmpty("A2:J2")
        Range("A2:J2").Cut Range("A1").End(xlToRight).Offset(0, 1)      '   Cut Range A2:J2 and paste to first empty cell Row 1
        Rows(2).EntireRow.Delete                                        '   Delete 2nd Row and shift cells up
'
        If Range("A2") = vbNullString Then Exit Do                      '   If Row 2 is empty then exit loop
    Loop                                                                ' If Row 2 is not empty then loop back
'
    RowCounter = 1                                                                              ' Initiate our RowCounter
'
    Do While Range("A" & RowCounter) >= 0
        Range("A" & RowCounter).Offset(0, 1).Select                                             ' Bx is selected at this point
'
        Do Until ActiveCell = 9999                                                              ' Search each row for first instance of 9999 after A2
            ActiveCell.Offset(0, 1).Select
'
            If (IsEmpty(ActiveCell)) Then GoTo TimeTrialEnd                                              ' If no more data then exit sub
        Loop
'
'       Copy data from that cell to end of line & Paste data on next row down
        Range(ActiveCell, ActiveCell.End(xlToRight)).Cut ActiveCell.End(xlToLeft).Offset(1, 0)
'
        RowCounter = RowCounter + 1                                                             ' Increment our RowCounter
    Loop
'
TimeTrialEnd:
'
'   Turn Settings back on
    Application.EnableEvents = True                                                             ' Turn EnableEvents back on
    Application.Calculation = xlCalculationAutomatic                                            ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                                           ' Turn Screen Updating back on
End Sub

If you want faster than that then arrays are probably the next step, but try that last bit of code and see if it still takes minutes to complete. An answer to your question of several hundred rows taking minutes to complete is not normal.

 

[jolivanes]

I don't understand your need.
Does this result in part what you need? (Make sure you have an empty Sheet3)
And of course use a copy of your original.

Sub What_Gives()
Dim i As Long
Application.ScreenUpdating = False
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        On Error Resume Next
            Cells(i, 1).Resize(, Rows(i).Find(9999).Column - 1).Delete Shift:=xlToLeft
        On Error GoTo 0
    Next i
    
    With ActiveSheet.Cells(1, 1).CurrentRegion
        .AutoFilter 1, 9999
            .Offset(1).Copy Sheets("Sheet3").Cells(1, 1)
        .AutoFilter
    End With
Application.ScreenUpdating = True
End Sub

 

[HanR]

Without using Arrays to make it faster ...

Post #1 in this thread = Avg = 3.2265625 for the data that you provided
Post #2 in this thread = Avg = 1.7109375

The following code should Avg about 0.2546875 for the data that you provided:

Sub MyOrganizeDataSpeedUpV2()                                                               ' Avg 0.2546875
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim RowCounter  As Long
'
    Rows(1).EntireRow.Delete                                            ' Deletes Header Row and shifts cells up
    Columns(1).EntireColumn.Delete                                      ' Deletes Header Column and shifts cells left
'
    Do Until IsEmpty("A2:J2")
        Range("A2:J2").Cut Range("A1").End(xlToRight).Offset(0, 1)      '   Cut Range A2:J2 and paste to first empty cell Row 1
        Rows(2).EntireRow.Delete                                        '   Delete 2nd Row and shift cells up
'
        If Range("A2") = vbNullString Then Exit Do                      '   If Row 2 is empty then exit loop
    Loop                                                                ' If Row 2 is not empty then loop back
'
    RowCounter = 1                                                                              ' Initiate our RowCounter
'
    Do While Range("A" & RowCounter) >= 0
        Range("A" & RowCounter).Offset(0, 1).Select                                             ' Bx is selected at this point
'
        Do Until ActiveCell = 9999                                                              ' Search each row for first instance of 9999 after A2
            ActiveCell.Offset(0, 1).Select
'
            If (IsEmpty(ActiveCell)) Then GoTo TimeTrialEnd                                              ' If no more data then exit sub
        Loop
'
'       Copy data from that cell to end of line & Paste data on next row down
        Range(ActiveCell, ActiveCell.End(xlToRight)).Cut ActiveCell.End(xlToLeft).Offset(1, 0)
'
        RowCounter = RowCounter + 1                                                             ' Increment our RowCounter
    Loop
'
TimeTrialEnd:
'
'   Turn Settings back on
    Application.EnableEvents = True                                                             ' Turn EnableEvents back on
    Application.Calculation = xlCalculationAutomatic                                            ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                                           ' Turn Screen Updating back on
End Sub

If you want faster than that then arrays are probably the next step, but try that last bit of code and see if it still takes minutes to complete. An answer to your question of several hundred rows taking minutes to complete is not normal.

Wow! That was incredibly fast! It only took a couple seconds! I also like that the screen isn't flashing through each command. That is a really neat piece of code that I will definitely be using in the future. Thank you again for all of your help. It would have taken me a week or more to sort some of this out! Plus I was able to learn what you did and apply it to the rest of my code that I am working on. Thank you!

 

[HanR]

I don't understand your need.
Does this result in part what you need? (Make sure you have an empty Sheet3)
And of course use a copy of your original.

Sub What_Gives()
Dim i As Long
Application.ScreenUpdating = False
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        On Error Resume Next
            Cells(i, 1).Resize(, Rows(i).Find(9999).Column - 1).Delete Shift:=xlToLeft
        On Error GoTo 0
    Next i
   
    With ActiveSheet.Cells(1, 1).CurrentRegion
        .AutoFilter 1, 9999
            .Offset(1).Copy Sheets("Sheet3").Cells(1, 1)
        .AutoFilter
    End With
Application.ScreenUpdating = True
End Sub

Thank you for taking a look at this! My request is really random since I am using an older machine that is outputting my data. I need each line to start with '9999' which is the machine telling me it's a new data set. I then need all data in a single row after that 9999. This definitely sorted the data and got the 9999 in the right spot, but the data after that was split on a few different rows. My code I posted works, but it would take a minute or 2 to run since I am new to coding and did a bunch of bulky commands. Here is a picture of what the result looks like.

 

[johnnyL]

Here is an array approach that I came up with. It is not very eloquent, I am sure, but it times in at about the same as the previous script that I posted for your limited set of data. It would probably fair better with a larger set of data, ie more than 29 rows of data.

Try it out and let us know how it compares with your larger set of data:

Sub OrganizeDataViaArraysV1()                                          ' Avg. = 0.25234375
'
    Dim ArrayColumnCounter          As Long
    Dim ArrayColumnLoop             As Long
    Dim ArrayMaxColumn              As Long
    Dim ArrayRowLoop                As Long
    Dim LastRowInSheet              As Long
    Dim ColumnCounter               As Long
    Dim ResultsStartRowNumber       As Long
    Dim ResultsStartColumnNumber    As Long
    Dim ArrayRowCounter             As Long
    Dim FinalArray()                As Variant
    Dim InitialArray                As Variant
    Dim ArrayList                   As Object
'
    ResultsStartColumnNumber = 1                                                                ' <--- Set this to starting column number to display results
    ResultsStartRowNumber = 1                                                                   ' <--- Set this to starting row to display results
'
    ReDim FinalArray(1 To 10000, 1 To 500)                                                      ' Establish a large 2 dimensional array that we will resize later
'
    Set ArrayList = CreateObject("System.Collections.ArrayList")
    ArrayList.Add "Header"                                                                      ' Fill the zero slot of ArrayList
'
    Rows(1).EntireRow.Delete                                                                    ' Delete Header Row and shifts cells up
    Columns(1).EntireColumn.Delete                                                              ' Delete Header Column and shifts cells left
'
    LastRowInSheet = Range("A" & Rows.Count).End(xlUp).Row                                      ' Returns a row number
'
    InitialArray = Range("A1:J" & LastRowInSheet)                                               ' Load the sheet values into a 2 dimensional 1 based array
'
    Range("A1:J" & LastRowInSheet).ClearContents                                                ' delete the sheet cell values
'
    For ArrayRowLoop = LBound(InitialArray, 1) To UBound(InitialArray, 1)                       ' Loops to load ArrayList with all values from InitialArray
        For ArrayColumnLoop = LBound(InitialArray, 2) To UBound(InitialArray, 2)
            ArrayList.Add InitialArray(ArrayRowLoop, ArrayColumnLoop)
        Next
    Next
'
'
'-----------------------------------------------------------------------------------------------------------------------------------------------
'
'
    ArrayColumnCounter = 1                                                                      ' Initialize ArrayColumn counter
    ArrayRowCounter = 1                                                                         ' Initialize ArrayRow counter
'
    For ColumnCounter = 1 To ArrayList.Count - 1                                                ' # of columns in ArrayList
        If ArrayList(ColumnCounter) <> 9999 Then                                                ' If value in ArrayList is not = 9999 then ...
            FinalArray(ArrayRowCounter, ArrayColumnCounter) = ArrayList(ColumnCounter)          '   add the value to FinalArray row
            If ArrayColumnCounter > ArrayMaxColumn Then ArrayMaxColumn = ArrayColumnCounter     '   if column is > than max saved counter then save as new max
            ArrayColumnCounter = ArrayColumnCounter + 1                                         '   increment ArrayColumn counter
        Else                                                                                    ' Else ... 9999 was found ;)
            ArrayColumnCounter = 1                                                              '   Reset ArrayColumn counter to 1
            ArrayRowCounter = ArrayRowCounter + 1                                               '   Increment ArrayRow counter
            FinalArray(ArrayRowCounter, ArrayColumnCounter) = ArrayList(ColumnCounter)          '   add the value to FinalArray new row
            ArrayColumnCounter = ArrayColumnCounter + 1                                         '   increment ArrayColumn counter
        End If
    Next
'
    FinalArray = ReDimPreserve(FinalArray, ArrayRowCounter, ArrayMaxColumn)                     ' Redim Both the dimensions of the array to its used size
'
    Range(Cells(ResultsStartRowNumber, ResultsStartColumnNumber), _
        Cells(ResultsStartRowNumber + ArrayRowCounter - 1, ResultsStartColumnNumber + ArrayMaxColumn - 1)) = FinalArray ' Display Results to sheet
End Sub

Private Function ReDimPreserve(MyArray As Variant, nNewFirstUBound As Long, nNewLastUBound As Long) As Variant

    Dim i As Long, j As Long
    Dim nOldFirstUBound As Long, nOldLastUBound As Long, nOldFirstLBound As Long, nOldLastLBound As Long
    Dim TempArray() As Variant 'Change this to "String" or any other data type if want it to work for arrays other than Variants. MsgBox UCase(TypeName(MyArray))
'---------------------------------------------------------------
'COMMENT THIS BLOCK OUT IF YOU CHANGE THE DATA TYPE OF TempArray
    If InStr(1, UCase(TypeName(MyArray)), "VARIANT") = 0 Then
        MsgBox "This function only works if your array is a Variant Data Type." & vbNewLine & _
               "You have two choice:" & vbNewLine & _
               " 1) Change your array to a Variant and try again." & vbNewLine & _
               " 2) Change the DataType of TempArray to match your array and comment the top block out of the function ReDimPreserve" _
                , vbCritical, "Invalid Array Data Type"
        End
    End If
'---------------------------------------------------------------
    ReDimPreserve = False
'
'   check if its in array first
    If Not IsArray(MyArray) Then MsgBox "You didn't pass the function an array.", vbCritical, "No Array Detected": End
'
'   get old lBound/uBound
    nOldFirstUBound = UBound(MyArray, 1): nOldLastUBound = UBound(MyArray, 2)
    nOldFirstLBound = LBound(MyArray, 1): nOldLastLBound = LBound(MyArray, 2)
'
'   create new array
    ReDim TempArray(nOldFirstLBound To nNewFirstUBound, nOldLastLBound To nNewLastUBound)
'
'   loop through first
    For i = LBound(MyArray, 1) To nNewFirstUBound
        For j = LBound(MyArray, 2) To nNewLastUBound
            'if its in range, then append to new array the same way
            If nOldFirstUBound >= i And nOldLastUBound >= j Then
                TempArray(i, j) = MyArray(i, j)
            End If
        Next
    Next
'
'   return the array redimmed
    If IsArray(TempArray) Then ReDimPreserve = TempArray
End Function

It uses a UDF that can resize both dimensions of the 2 dimensional array it uses to store the final results in.

 

[jolivanes]

Re: "but the data after that was split on a few different rows" ?????
Not on the result in my test showing on sheet3.

 

[HanR]

Re: "but the data after that was split on a few different rows" ?????
Not on the result in my test showing on sheet3.

Right! On Sheet 3 the data seemed snipped. Some lines were really short. Your code was way more advanced than I can read (still very very new), so I wasn't quite sure if I was reading the lines wrong, but each data set should have 15ish columns of numbers, give or take.