Sub CopySortPaste()
'This finds the total number of columns and rows used in the spreadsheet
iTotColumns = Sheets("PasteHere").UsedRange.Columns.Count
iTotRows = Sheets("PasteHere").UsedRange.Rows.Count
'This will give the array the dimensions it needs to fit the data
ReDim MyArray(iTotRows, iTotColumns)
'This will begin the for loop which will store the data in a 2 dimensional array
'The first for loop stores the column number
For ColCount = 1 To iTotColumns
'This will begin the nested for loop which cycles through the rows
For RowCount = 1 To iTotRows
'This is storing the data located in each cell in its individual place in the array
MyArray(RowCount, ColCount) = Sheets("PasteHere").Cells(RowCount, ColCount)
Next RowCount
Next ColCount
'This activates the sheet which the data is being transferred to and then selecting the first cell
Sheets("Equipment").Activate
Range("A1").Select
'This finds the total number of rows used in the document we are transferring to. By doing this,
'we can insert the new data at the bottom of the new sheet.
iNewTotRowsUsed = ActiveSheet.UsedRange.Rows.Count
'Because the previous bit of code is usually inaccurate, this Do Until loop has been added
'to make sure that the last cell used in the document (by the computer's standards) is indeed
'the last used cell.
Do Until Cells(iNewTotRowsUsed, 1) <> ""
iNewTotRowsUsed = iNewTotRowsUsed - 1
Loop
'This begins the for loop which will be used to transfer the data from the array to the spreadsheet
For ColCount = 1 To iTotColumns
For RowCount = 1 To iTotRows
'The RowCount variable keeps track of which piece of data to pull from the array
'If RowCount = 1, then it must be the heading and not a piece of equipment
If RowCount = 1 Then
'This will store the heading name in a variable which will be used for searching.
'The goal is to find the heading in the new document and then input the data from
'the array into the spreadsheet below the heading.
sHeading = MyArray(RowCount, ColCount)
'This is the label for when there is an error. Specifically, it is for when the heading
'can not be found when using the find command. If the heading can not be found, it will
'go to the label "HeadingNotFound", which offers to create a new heading.
ErrorHandling:
On Error GoTo HeadingNotFound
'This command will search the document for the heading title. Once it has found it,
'the program will begin to list the data below the heading at the bottom of the table.
Cells.Find(What:=sHeading, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
'iColNumber is a new variable which gets the column number of the active cell, which should be
'the heading which was just searched for.
iColNumber = ActiveCell.Column
'The RowCount variable must be incremented by 1 so that the heading from the array is not
'placed within the document. iRowNumber has been set to the value of the row after the
'very last row which has been used in the document. iNewTotRowsUsed is the variable which
'holds the row number of the last non blank cell in the document being transferred to.
RowCount = RowCount + 1
iRowNumber = iNewTotRowsUsed + 1
'This places the data from the array into the new data sheet
ActiveSheet.Cells(iRowNumber, iColNumber) = MyArray(RowCount, ColCount)
End If
If RowCount > 2 Then
iRowNumber = iRowNumber + 1
ActiveSheet.Cells(iRowNumber, iColNumber) = MyArray(RowCount, ColCount)
End If
Next RowCount
Next ColCount
Exit Sub
'This is where the program runs if the find command could not find the
'heading it was searching for. It will produce a message asking if the
'user would like to sort the data beneath a user-selected column heading.
HeadingNotFound:
Msg = "It appears one of your headings, " & sHeading
Msg = Msg & " could not be found. Would you like "
Msg = Msg & "to choose which heading to put its data under?"
Ans1 = MsgBox(Msg, vbYesNo, "Heading Not Found")
If Ans1 = vbYes Then
On Error GoTo 0
GoTo SelectHeading
Else
GoTo NewColumn
End If
SelectHeading:
'Need to let the user select the proper heading.
Dim rng As Variant
Set rng = Nothing
On Error Resume Next
rng = Application.InputBox(prompt:="Select the heading you wish to use for " & sHeading & ".", Default:=Cells(4, 2).Value, Type:=8)
If rng = False Then
Resume HeadingNotFound
Else
sHeading = rng.Value
Resume ErrorHandling
'Else
'Resume HeadingNotFound
End If
NewColumn:
NewMsg = "Would you like to put this data in a new "
NewMsg = NewMsg & "column under the heading " & sHeading & "?"
Ans2 = MsgBox(NewMsg, vbYesNo, "New Column?")
If Ans2 = vbYes Then
Msg = "Please select where you would like to place this heading. "
Msg = Msg & "The column will be placed between the cell you select "
Msg = Msg & "and the cell to its left."
Set rng = Application.InputBox(prompt:=Msg, Type:=8)
iColNumber = rng.Column
ActiveSheet.Cells(4, iColNumber).Activate
ActiveCell.EntireColumn.Insert (xlRight)
Cells(4, iColNumber) = sHeading
Resume ErrorHandling
Else
GoTo DoNothing
End If
DoNothing:
If ColCount <> iTotColumns Then
ColCount = ColCount + 1
sHeading = MyArray(RowCount, ColCount)
Resume ErrorHandling
Else
Exit Sub
End If
End Sub
