Visual Basic, .NET, ASP, VBScript
Новости | Примеры | Библиотека кодов | НеЧаВо | VBA | Справочник по VB | Справочник по WinAPI | ActiveX контролы | Статьи по VB | Мастерская разработчика | Форум VBNet | Яndex bar! | Голосование | Полезные программы | Магазин VBNet | Рассылка | Конкурсы | Юмор | Чат | Реклама на VBNet | Автора! | Ссылки | Бета-тестирование | Послать пример на сайт
 

   
   
     

Форум - VBA

Страница: 1 |

 

  Вопрос: Помогите написать цикл Добавлено: 23.10.08 11:39  

Автор вопроса:  гость | Web-сайт: http://garden.gov.ua | ICQ: 472928857 
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

Ответить

  Ответы Всего ответов: 4  

Номер ответа: 1
Автор ответа:
 Dima



Вопросов: 6
Ответов: 10
  Профиль | | #1 Добавлено: 24.10.08 13:25
Ничего не понял! В чем проблема? Сам скрипт-то написал? В чем проблема for-to-next сделать

Ответить

Номер ответа: 2
Автор ответа:
 гость



ICQ: 472928857 

Вопросов: 2
Ответов: 1
  Web-сайт: http://garden.gov.ua
 Профиль | | #2 		Добавлено: 24.10.08 14:06
В алгоритме, как сделать оптимально. можно например так, через фильтр:
  1.  
  2.  
  3. Private Sub GetUniqueValue()
  4.  
  5.     Application.ScreenUpdating = False
  6.     
  7.     wsUnique.UsedRange.Clear
  8.     
  9.     Dim iColumn As Range, iTarget As Range
  10.     For Each iColumn In Me.UsedRange.Columns
  11.         Select Case iColumn.Column
  12.             Case 2, 4 To 256 'Case 2, Is > 3
  13.             Set iTarget = wsUnique.[A65536].End(xlUp)(2)
  14.             iColumn.AdvancedFilter _
  15.             Action:=xlFilterCopy, CopyToRange:=iTarget, Unique:=True
  16.             With wsUnique.Range(iTarget(2), wsUnique.[A65536].End(xlUp))
  17.                  iCountIfAll = Application.CountIf(iColumn.Offset(1), .Cells)
  18.                  iSum& = Application.Sum(iCountIfAll)
  19.                  .Offset(, 1).Value = iCountIfAll
  20.                  .Offset(, 2).Value = Evaluate(.Offset(, 1).Address(External:=True) & "/" & iSum& & "*100")
  21.                  With .Resize(1, 3).Offset(.Count)
  22.                       .Value = Array("Сумма", iSum&, "100%")
  23.                       .Font.Color = vbRed
  24.                  End With
  25.             End With
  26.         End Select
  27.     Next
  28.     With wsUnique.UsedRange
  29.          If Application.CountBlank(.Columns(1)) > 0 Then _
  30.          .Columns(1).SpecialCells(xlBlanks).EntireRow.Delete
  31.  
  32.          .EntireColumn.AutoFit
  33.     End With
  34.     
  35.     Application.ScreenUpdating = True
  36. End Sub


но мне чем-то не нравиться такое решение - ищу более красивого, что-ли.

Ответить

Номер ответа: 3
Автор ответа:
 mc-black



ICQ: 308-534-060 

Вопросов: 20
Ответов: 1860
  Web-сайт: mc-black.narod.ru/dzp.htm
 Профиль | | #3 		Добавлено: 24.10.08 18:29
  1. do while ... loop?

Ответить

Номер ответа: 4
Автор ответа:
 quest



Вопросов: 5
Ответов: 34
  Профиль | | #4 Добавлено: 24.10.08 18:35
  1.  
  2.         Application.ScreenUpdating = False
  3.     
  4.     wsUnique.UsedRange.Clear
  5.     
  6.     Dim iColumn As Range, iTarget As Range
  7.     For Each iColumn In Me.UsedRange.Columns
  8.         Select Case iColumn.Column
  9.             Case 2, 4 To 256 'Case 2, Is > 3
  10.             Set iTarget = wsUnique.[A65536].End(xlUp)(2)
  11.             iColumn.AdvancedFilter _
  12.             Action:=xlFilterCopy, CopyToRange:=iTarget, Unique:=True
  13.             With wsUnique.Range(iTarget(2), wsUnique.[A65536].End(xlUp))
  14.                  iCountIfAll = Application.CountIf(iColumn.Offset(1), .Cells)
  15.                  iSum& = Application.Sum(iCountIfAll)
  16.                  .Offset(, 1).Value = iCountIfAll
  17.                  .Offset(, 2).Value = Evaluate(.Offset(, 1).Address(External:=True) & "/" & iSum& & "*100")
  18.                  With .Resize(1, 3).Offset(.Count)
  19.                       .Value = Array("Сумма", iSum&, "100%")
  20.                       .Font.Color = vbRed
  21.                  End With
  22.             End With
  23.         End Select
  24.     Next
  25.     With wsUnique.UsedRange
  26.          If Application.CountBlank(.Columns(1)) > 0 Then _
  27.          .Columns(1).SpecialCells(xlBlanks).EntireRow.Delete
  28.  
  29.          .EntireColumn.AutoFit
  30.     End With
  31.     
  32.     Application.ScreenUpdating = True

Ответить

Страница: 1 |

Поиск по форуму



© Copyright 2002-2011 VBNet.RU | Пишите нам