Option Explicit
Sub ex_resp()
Dim _
lngLastRow As Long, wksSource As Worksheet, _
lngRow As Long, rngDestination As Range, _
lngUpper As Long, strRatingType As String, _
lngLower As Long, DataArray() As Variant, _
lngInnerRow As Long, _
lngUbound As Long
Set wksSource = ThisWorkbook.Worksheets("BriefingAnalystUpsDwnsQuery")
With wksSource
'// Find the last row used as you were doing //
lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
'// Initially dimension our array as 8 x 1. While this seems //
'// backwards, this will allow us to keep the values being added //
'// preserved as the second dimension resizes (grows) //
ReDim DataArray(0 To 7, 0)
'// I started the loop out at 4 rather than 1. If it did find //
'// "Company" in any row less than four, this would cause an error //
'// when looking three rows up (as three rows up would be zero or //
'// less). //
For lngRow = 4 To lngLastRow
If .Cells(lngRow, 1).Value = "Company" Then
Select Case .Cells(lngRow - 3, 1).Value
Case "Upgrades"
strRatingType = "Upgrades"
Case "Downgrades"
strRatingType = "Downgrades"
Case "Coverage Initiated"
strRatingType = "Initiated"
Case "Coverage Reit/Price Tgt Changed*"
strRatingType = "TargetChange"
End Select
'// Since lngRow will be the row we found "Company" on, we //
'// should be able to figure the first row to start grabbing//
'// as well as the bottom of the CurrentRegion. //
lngUpper = lngRow + 1
lngLower = wksSource.Cells(lngUpper, 1).End(xlDown).Row
'// Now since we know where we stopped grabbing data, //
'// rather than having our outer loop //
'// (For lngRow = 4 To lngLastRow) start looking only one //
'// row below the last "Company", we'll just adjust up //
'// lngRow here. //
lngRow = lngLower + 1
'// ...Back to our CurrentRegion, we'll loop thru and build //
'// our array. //
For lngInnerRow = lngUpper To lngLower
'// We find out what the current upper bound of the //
'// second dimension is... //
lngUbound = UBound(DataArray(), 2)
'// ...and assign values to ea element of the first //
'// dimension at this position; //
DataArray(0, lngUbound) = .Cells(lngInnerRow, 1).Value
DataArray(1, lngUbound) = .Cells(lngInnerRow, 2).Value
DataArray(2, lngUbound) = .Cells(lngInnerRow, 3).Value
DataArray(3, lngUbound) = .Cells(lngInnerRow, 4).Value
DataArray(4, lngUbound) = .Cells(lngInnerRow, 5).Value
DataArray(5, lngUbound) = .Cells(lngInnerRow, 6).Value
DataArray(6, lngUbound) = .Cells(lngInnerRow, 7).Value
'// ...excepting of course the val we needed to snag //
'// from above the "table"/CurrentRegion. //
DataArray(7, lngUbound) = strRatingType
'// Now we'll redimension our array for the next loop. //
'// The last trip thru our loop will add an unnecessary //
'// element to the second dimension, which we'll strip //
'// when done looping. //
ReDim Preserve DataArray(0 To 7, UBound(DataArray(), 2) + 1)
Next
End If
Next lngRow
End With
'// Delete the last element from ea of the elements in the first //
'// dimension. //
ReDim Preserve DataArray(0 To 7, UBound(DataArray(), 2) - 1)
'// We've got our data, so off to the destination sheet. //
With ThisWorkbook.Worksheets("BriefingAnalystUpsDwns")
'// So as if theres stuff from a prior day/period, clear. I left //
'// a header row. //
.Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row).EntireRow.Delete
'// Rather than loop thru ea value in our, figure out the size that //
'// the array/range will be once it is transposed, and set a range //
'// to the same size. //
Set rngDestination = .Range(.Cells(2, 1), _
.Cells(UBound(DataArray(), 2) + 2, 8))
'// Wack it into place and size the columns //
rngDestination = Application.WorksheetFunction.Transpose(DataArray)
.Columns("A:H").EntireColumn.AutoFit
End With
End Sub
