Sub MizzouIV(): Dim wt As Worksheet, ws As Worksheet, F As Range
Dim Z, n As Long, r As Long, t As Long: t = 2
Set wt = Sheets("Ideal Table")
For Each ws In Worksheets
If IsNumeric(ws.Name) Then
Z = Split(ws.Cells(5, 2))
wt.Cells(t, 1) = Z(0): wt.Cells(t, 3) = Z(UBound(Z))
wt.Cells(t, 2) = IIf(UBound(Z) = 2, Z(1), "")
Z = Split(ws.Cells(8, 2), ","): wt.Cells(t, 4) = Z(UBound(Z))
Z = Split(ws.Cells(7, 2), ":"): wt.Cells(t, 5) = Z(UBound(Z))
Z = Split(ws.Cells(9, 2), ":"): wt.Cells(t, 6) = Z(UBound(Z))
Z = Split(ws.Cells(6, 6), ":"): wt.Cells(t, 7) = Z(UBound(Z))
Z = Split(ws.Cells(7, 6), ":"): wt.Cells(t, 8) = Z(UBound(Z))
Z = Split(ws.Cells(8, 6), ":"): wt.Cells(t, 9) = Z(UBound(Z))
Z = Split(ws.Cells(6, 2), ",")
wt.Cells(t, 10) = Z(0): wt.Cells(t, 11) = Z(UBound(Z))
Z = Split(ws.Cells(9, 6), ":"): wt.Cells(t, 12) = Trim(Z(UBound(Z)))
wt.Cells(t, 12) = Replace(wt.Cells(t, 12), ",", "")
If InStr(1, wt.Cells(t, 12), " ") Then Z = Split(wt.Cells(t, 12)) _
: wt.Cells(t, 13) = Z(1): wt.Cells(t, 12) = Z(0)
If UBound(Z) = 2 Then wt.Cells(t, 14) = Z(UBound(Z))
Z = Split(ws.Cells(7, 10), ":"): wt.Cells(t, 15) = Z(UBound(Z))
For n = 16 To 24
Set F = ws.Range("A:A").Find(wt.Cells(1, n), Lookat:=xlWhole)
If Not F Is Nothing Then wt.Cells(t, n) = F.Offset(0, 1)
Next n
r = 11: Do Until ws.Cells(r, 1) = "Survey Comment"
If r > 50 Then Exit Do
r = r + 1: Loop
wt.Cells(t, n) = ws.Cells(r + 1, 1)
t = t + 1: End If: Next: End Sub
Bookmarks