Sub ExtractParameters()
' By: Jason Green
' LunaMetrics
' 2007-12-12

Dim i As Integer
Dim findQuestion As String
Dim myNewString As String
Dim myCell As String
Dim myRow As Integer
Dim myCol As Integer

i = 1
myRow = 1
myCol = 1


Do Until i = 550
myCell = ActiveSheet.Cells(myRow, myCol)

If InStr(myCell, "?") > 0 Then
    findQuestion = InStr(myCell, "?") + 1
    myNewString = Mid(myCell, findQuestion, 100)
    
    ActiveSheet.Cells(myRow, myCol + 1) = myNewString
End If
 myRow = myRow + 1
 
    
    i = i + 1

Loop

'*************************
Dim findEquals As String
Dim remainParams As String
Dim j As Integer
Dim findAmp As String
Dim param As String

j = 1

myCol = 2

Do Until j = 10     'Expected number of parameters
i = 1
myRow = 1

        Do Until i = 555    'Number of rows of data
        
        myCell = ActiveSheet.Cells(myRow, myCol)
        
            If InStr(myCell, "=") > 0 Then
                findEquals = InStr(myCell, "=")                         ' Find the index of the equal sign
                param = Mid(myCell, 1, findEquals - 1)                  ' param = myCell from crc 1 to (the index found above - 1)
                remainParams = Mid(myCell, findEquals + 1, 100)         ' remainParams = everything remaining after the equal sign
                
                    If InStr(remainParams, "&") > 0 Then
                        findAmp = InStr(remainParams, "&") + 1          ' in the remaining string, find the index of the &
                        remainParams = Mid(remainParams, findAmp, 100)  ' lose the & and everything before
                    End If
                                            
                ActiveSheet.Cells(myRow, myCol + 1) = param
                If InStr(remainParams, "=") > 0 Then                    ' Only copy the remaining parameters if there still are some.
                    ActiveSheet.Cells(myRow, myCol + 2) = remainParams
                End If
            
            End If
            
        i = i + 1
        myRow = myRow + 1
        
        Loop


j = j + 1
myCol = myCol + 2

Loop


' Now we'll delete all the extra stuff...
Dim k As Integer
k = 4

Do Until k = 10
Columns(k).Delete Shift:=xlToLeft
k = k + 1
Loop


' Create a new sheet named Parameters **************************************

    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(2).Select
    Sheets(2).Name = "Parameters"


' Copy all the parameters from their separate columns into one large column.***************************
'
    Sheets(1).Select ' go back to the first sheet

    Range("D2:D505").Cut
    Range("C506").Select   ' The cell to begin copying to
    ActiveSheet.Paste
        
    Range("E2:E505").Cut
    Range("C1012").Select    ' The cell to begin copying to
    ActiveSheet.Paste


    Range("F2:F505").Cut
    Range("C1519").Select    ' The cell to begin copying to
    ActiveSheet.Paste

    Range("G2:G505").Cut
    Range("C2025").Select    ' The cell to begin copying to
    ActiveSheet.Paste

    Range("H2:H505").Cut
    Range("C2531").Select    ' The cell to begin copying to
    ActiveSheet.Paste

    Range("I2:I505").Cut
    Range("C3037").Select    ' The cell to begin copying to
    ActiveSheet.Paste
    

    
    ' ** Copy params to new sheet **
    Columns("C:C").Cut
    Sheets("Parameters").Select
    Columns("A:A").Select
    ActiveSheet.Paste
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "Parameters"
    Range("A1").Select
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("A:A").EntireColumn.AutoFit
    Range("A1").Select

    
    ' Now we filter out all of the duplicates.
    Dim x               As Long
    Dim LastRow         As Long
     
    LastRow = Range("A4000").End(xlUp).Row
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
            Range("A" & x).EntireRow.Delete
        End If
    Next x


    ' Now we can delete Column B
    Sheets(1).Select
    Columns(2).Delete Shift:=xlToLeft
    Range("A1").Select
    


End Sub