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!

 

[jolivanes]

Re: "each data set should have 15ish columns of numbers, give or take."
Not in your picture in Post #1

 

[jolivanes]

If you want the result in the same sheet, try it so.
Remember, on a copy first. Gone is gone and can't be undone.

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
        With .Cells(1, 1).CurrentRegion
            .AutoFilter 1, "<>" & 9999
                .SpecialCells(xlCellTypeVisible).EntireRow.Delete
            End With
        .AutoFilterMode = False
    End With
Application.ScreenUpdating = True
End Sub

 

[HanR]

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.

When I ran it I got "Run-time error '-2146232576 (80131700)': Automation error" for line "Set ArrayList = CreateObject ("System.Collections.ArrayList"). To be honest arrays are way outside of my realm of knowledge, so I think I will stick to your previous solution I am happy to wait 13 seconds to run a Macro that saves me 3 or 4 hours of work! I wanted to pass along the error code in case you were curious. (Its possible I did something wrong as I haven't ever used an Array before.
Thank you again for your help!

 

[HanR]

If you want the result in the same sheet, try it so.
Remember, on a copy first. Gone is gone and can't be undone.

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
        With .Cells(1, 1).CurrentRegion
            .AutoFilter 1, "<>" & 9999
                .SpecialCells(xlCellTypeVisible).EntireRow.Delete
            End With
        .AutoFilterMode = False
    End With
Application.ScreenUpdating = True
End Sub

There still is a lot of data missing. But I have a solution already, so I don't want you wasting your time with my project Thank you again for taking a look at it! I appreciate your time!

 

[johnnyL]

When I ran it I got "Run-time error '-2146232576 (80131700)': Automation error" for line "Set ArrayList = CreateObject ("System.Collections.ArrayList").

It sounds like you are missing net framework 3.51 on your computer.

Help link