Помогите написать цикл

[claus]

http://garden.gov.ua/failo/proc.xls - некая таблица произвольного размера. Мне нужно по каждой колонке (кроме а и с) пдсчитать % каждого уникального значения (пример результата - внизу под таблицей - выделен красным). Сам скрипт есть (на листе 1) - нужно только его подправить и под него цикл сделать, чтоб пробежать по тем колонкам и результат поместить внизу, под таблицей, или на новом листе.
Вот код, с которым я работал:

Код: Выделить всё

Public Sub ProcOfUniq()
'В редакторе VBA в меню Tools, пункт Reference
' в диалоге поставте галочку для Microsoft Scripting Runtime.
   
    Dim pAll As New Scripting.Dictionary
    Dim rowLast As Long, Column_A As Long
    Dim w1 As Worksheet
    Dim iRow As Long, i As Long, vEntry As String
    Dim iCountAll As Long

    Set w1 = ActiveWorkbook.ActiveSheet
       
    Column_A = 2&
    rowLast = Cells(w1.UsedRange.Rows.Count + 1, Column_A).End(xlUp).Row
           
    iCountAll = 0
    For iRow = 1& To rowLast
      If Not IsEmpty(w1.Cells(iRow, Column_A)) Then
        vEntry = CStr(w1.Cells(iRow, Column_A).Value)
        If Not pAll.Exists(vEntry) Then
           pAll.Add vEntry, 1
        Else
           pAll.item(vEntry) = pAll.item(vEntry) + 1
        End If
        iCountAll = iCountAll + 1
      End If
    Next iRow
     
    For i = 0 To pAll.Count - 1
      Cells(i + 1, "E") = pAll.Keys(i)
      Cells(i + 1, "F") = pAll.Items(i)
      With Cells(i + 1, "h")
        .Formula = "= " & Cells(i + 1, "F").Address & "/" & _
                        Str(iCountAll)
        .NumberFormat = "0.00%"
      End With
    Next i
     
    ' подсчитаем сумму всех процентов - должно быть 100% всегда!
    With Cells(pAll.Count + 1, "h")
      .Formula = "=SUM(h1:h" & Trim(Str(pAll.Count)) & ")"
        .NumberFormat = "0.00%"
    End With
     
     
End Sub