0

source is on top converted to bottom

I have an Excel sheet where my user has counted the number of animals observed during her flight. I have to find a way to split her input into multiple rows where only one animal type is on each row. From the example, you can see that she saw 5 animals (of 2 types) associated with that day, flight line and waypoint (i.e. columns A-E) --> what I need to do is display that using 2 lines as there are 2 entries on the original row. Finally, there are 36 columns that can contain count values and around 9000 original rows to go through.

I am not proficient in VBA at all. If you Folks could point me in the right direction, I should be able to hack something together.

Thanks Layne

Layne Seely
  • 1

2 Answers2

0

A manual way to do it, still a bit of work with 36 cycles, but much less than 9000 rows, is to make a copy of the sheet and delete all but one of the animal count data columns. Do this for each desired columns. Then cut and paste the results of all the sheets on to one, making one large table. Use sort to get all the dates organized back together by row.

Ack
  • 633
  • 4
  • 12
0

Folks: Here is what I finally came up with. There is a class as well to simply act as a collection. Please let me know if there is a more efficient way to do this.

{Option Explicit

Function LastRowWithData_xlUp_1() As Long ' LS Grabbed from Web 'use End(xlUp) to determine Last Row with Data, in one column (column B) 'Rows.count returns the last row of the worksheet (which in Excel 2007 is 1,048,576); Cells(Rows.count, "B") returns the cell B1048576, ie. last cell in column B, and the code starts from this cell moving upwards; the code is bascially executing Range("B1048576").End(xlUp), and Range("B1048576").End(xlUp).Row finally returns the last row number. LastRowWithData_xlUp_1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

End Function

Function LastColumnWithData_xlToLeft() As Long ' LS Grabbed from Web 'use End(xlToLeft) to determine Last Column with Data, in one row (row number 1) LastColumnWithData_xlToLeft = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

End Function

Function sheetExists(sheetToFind As String, Optional InWorkbook As Workbook) As Boolean ' LS Grabbed from Web ' This function will look to see if the specified whorksheet exists or not. If InWorkbook Is Nothing Then Set InWorkbook = ThisWorkbook Dim Sheet As Object For Each Sheet In InWorkbook.Sheets If sheetToFind = Sheet.Name Then sheetExists = True Exit Function End If Next Sheet sheetExists = False End Function

Sub Normalizer() ' Created by Layne Seely with HUGE support from Jon. ' Declare some Variables related to the active Excel Workbook and the sheets required/needed. Dim wbWB As Workbook Dim wsWkSt1 As Worksheet Dim wsWkSt2 As Worksheet

' Declare some counters for rows, columns and a couple of general counters.
Dim iColCnt As Integer
Dim iRwCnt As Integer
Dim i As Integer
Dim j As Integer

' Declare some variables for the Class Module.
Dim col As New Collection
Dim PageNumber As String
Dim WMU As Integer
Dim DateVal
Dim WPT As Integer
Dim Line As Integer
Dim pr As clPreface
Dim colID As Integer
Dim p As Integer
Dim StartRow As Integer

' Set some Variable values to start them off.
iColCnt = 0
iRwCnt = 0
StartRow = 3
Set wbWB = ActiveWorkbook
Set wsWkSt1 = wbWB.ActiveSheet

' Check to see if Sheet2 (our created output) exists and create it if not.
If sheetExists("Sheet2") <> True Then
    Set wsWkSt2 = wbWB.Worksheets.Add(Type:=xlWorksheet)
    wsWkSt2.Name = "Sheet2"
End If

' Copy the Header row over to Sheet2.
iColCnt = Application.WorksheetFunction.CountA(wsWkSt1.Range("2:1"))
For i = 1 To iColCnt
    wsWkSt1.Cells(1, i).Copy Destination:=wsWkSt2.Cells(1, i)
    wsWkSt1.Cells(2, i).Copy Destination:=wsWkSt2.Cells(2, i)
Next i

' Get a count of the number or rows in the origanl data.
iRwCnt = Application.WorksheetFunction.CountA(wsWkSt1.Range("A:A"))

' Status update for the User.
MsgBox (" Reading the entire dataset - this may take a while. ")

' Read through the entire dataset collecting the necessary values into a collection of objects.
For i = 3 To iRwCnt

    ' Get the first 5 cells, the preface.
    PageNumber = wsWkSt1.Cells(i, 1)
    WMU = wsWkSt1.Cells(i, 2)
    DateVal = wsWkSt1.Cells(i, 3)
    WPT = wsWkSt1.Cells(i, 4)
    Line = wsWkSt1.Cells(i, 5)

    ' Begin stepping though each cell on row "i" collecting the non-blank cell values and their column index value.
    For j = 6 To iColCnt
        If wsWkSt1.Cells(i, j) <> vbNullString Then

            ' Create a new empty Preface Class Object.
            Set pr = New clPreface

            ' Set the values of the Preface object to the values of row "i".
            With pr
                .PageNumber = PageNumber
                .WMU = WMU
                .DateVal = DateVal
                .WPT = WPT
                .Line = Line
                .colID = j
                .Score = wsWkSt1.Cells(i, j)
            End With

            ' Add this row's values to the collection.
            col.Add pr

            ' Clear out the preface for the next non-blank column.
            Set pr = Nothing
        End If

    ' Increment the Column index.
    Next j

' increment the Row index.
Next i

' Status update for the User.
MsgBox (" Writing the output dataset - this may take a while. ")

' Begin writing out all of the objects in the collection to the output worksheet.
For p = 1 To col.Count
    Set pr = col.Item(p)

    With pr
        colID = .colID
        wsWkSt2.Cells(StartRow, 1) = .PageNumber
        wsWkSt2.Cells(StartRow, 2) = .WMU
        wsWkSt2.Cells(StartRow, 3) = .DateVal
        wsWkSt2.Cells(StartRow, 4) = .WPT
        wsWkSt2.Cells(StartRow, 5) = .Line
        wsWkSt2.Cells(StartRow, colID) = .Score
    End With

    Set pr = Nothing
    StartRow = StartRow + 1
Next

' Tell the User that the processing is now completed.
MsgBox (" End of Processing. ")

End Sub

}

Layne Seely
  • 1