VBA Excel, упорядочить данные по номерам счетов

[Lays]

Имеется отчет, выгруженный в Эксель (2003), он имеет вид стандартной конфигурации системы, из которой выгружается. Отчет состоит из трех таблиц, Остатки на счетах, Обороты по дебету, Обороты по кредиту. Каждая таблица состоит из трех колонок: Номер счета, Наименование счета, и Сумма (остатков или оборотов). Суть в том, чтобы собрать эти 3 таблицы в одну. Показано в прикрепленном файле,что есть и что должно быть…
Я реализовала макрос для ситуации если номера счетов повторяются, то есть по составу таблицы идентичны.
Как это сделать если номера счетов не всегда повторяются?
У меня цикл по тупому реализован, таблицы просто выстраиваются друг на против друга и нужные столбцы вырезаются и вставляются там где они нужны….

Помогите пожалуйста...не могу додуматься(((

[Hugo121]

Только идея (код писать некогда) - собираем в Dictionary уникальные по столбцам A&B (вероятно, может быть по одному счёту разное "Наименование счета", или нет?), затем по каждому элементу словаря цикл по исходному массиву, делим результат по группам по "---" или по "И Т О Г О".

[Lays]

Ох...сложновато понять...я на Си писала, на VBA вот только начала...
как сделать значения уникальными?

[Lays]

это отчет по просрочке, там у одного номера счета - одно наименование)))

[Hugo121]

Если одно наименование, тогда можно только по А анализировать.
Почитайте про Dictionary. У них есть метод .Exists, что позволяет легко, без лишних переборов, создать список уникальных элементов.
Ещё можно использовать Collection, но я предпочитаю словари.
Суть такая - проверяем, есть ли уже в словаре, если нет - заносим.
Затем перебор словаря и исходного массива.

Вот похожий пример (что нашёл, тут правда ещё массивы используются, но на небольшой объём можно не использовать):

отмечает "1" первое уникальное в 200000 строк за 0.8 сек. (20000*10)
повторам ставит "0"

Sub test()
Dim rng As Range
Dim arr1, arr2
Dim d As Scripting.Dictionary
Dim i As Long
Dim t As Double

t = Timer
Set d = New Dictionary
Set rng = [A2:A20000]
arr1 = rng.Value
ReDim arr2(1 To UBound(arr1), 1 To 1)

For i = 1 To UBound(arr1, 1)
If d.Exists(CStr(arr1(i, 1))) Then
arr2(i, 1) = 0
Else
d.Add CStr(arr1(i, 1)), 1
arr2(i, 1) = 1
End If
Next i

rng.Offset(, 3) = arr2
MsgBox (Timer - t) * 10
End Sub

P.S. Функция выбора уникальных целиком, на коллекции, с сортировкой, вполне можно использовать в задаче:

Function NoDups(Rng As Range, Optional Mask = "*")
  Dim Arr(), i&, s$, x
  ' Считать данные в массив, для удобства ограничиться последней строкой данных листа
  Arr = Intersect(Rng.Parent.UsedRange, Rng).Value
  ' Создать список
  On Error Resume Next
  With New Collection
    For Each x In Arr()
      s = Trim(x)
      If Len(s) > 0 Then
        If IsEmpty(.Item(s)) Then
          If s Like Mask Then
            ' Оригинальный достаточно быстрый вариант добавления значения в коллекцию с сортировкой (from PGC01)
            For i = 1 To .Count
              If s < .Item(i) Then Exit For
            Next
            If i > .Count Then .Add s, s Else .Add s, s, Before:=i
          End If
        End If
      End If
    Next
    ' Скопировать из коллекции в массив
    ReDim Arr(1 To .Count)
    For i = 1 To .Count
      Arr(i) = .Item(i)
    Next
  End With
  ' Вернуть массив
  NoDups = Arr()
End Function

[Hugo121]

Можно заготовку?

Sub tt()
    Dim a
    a = Range("a4:c20")
    For Each cc In NoDups(Range("a4:A20"))
        If Left(cc, 3) <> "---" Then
            For i = 1 To UBound(a)
                'здесь анализ массива
                'и копирование результата на другой лист/в другой файл
            Next
        End If
    Next
End Sub

Ниже/выше в код добавляете выше написанную функцию NoDups().

[Hugo121]

Ну вот, осталась рутина - iLastRow, шапка, подвал, с запятыми/точками разобраться, формулы внизу воткнуть или кодом посчитать...
На сегодня я всё, завтра днём тоже времени не будет, извините...

Option Explicit

Sub tt()
    Dim a, cc, block As Long, z As Long, i As Long
    Dim sh As Object
    
    Set sh = ThisWorkbook.Worksheets(2)
    a = Range("a4:c20")
    For Each cc In NoDups(Range("a4:A20"))
        block = 3
        z = z + 1
        sh.Cells(z, 1) = cc
        If Left(cc, 3) <> "---" Then
            For i = 1 To UBound(a)
                If Left(a(i, 1), 3) = "---" Then block = block + 1
                If Trim(a(i, 1)) = cc Then
                    sh.Cells(z, 2) = a(i, 2)
                    sh.Cells(z, block) = a(i, 3)
                End If
            Next
        End If
    Next
End Sub

[EugeneS]

можно, например, так, см. вложение

Предварительная настройка: Excel - Alt+F11 - VB redaktor: Tools – References: подключите (отметьте птичкой) библиотеку Microsoft ActiveX Data Objects 2.0 Library

Запустите макрос "Main"

[Lays]

Сделали немножко по-другому, раскидала свою таблицу на отдельные листы и оттуда собирала...фишка в том, что должно быть по идее 7 ситуаций, (1 - номер счета есть на листе, 0 - номера счета нет на листе). ситуации 111, 110,101,100, запроганы.... остались ситуации когда 001,011,010... и я зависла...

Sub Create_Separate_Sheets()
Dim lngRow As Long
Dim lastRow As Long
Dim i As Long
Dim flagD As Boolean
Dim flagK As Boolean
Dim lngD As Long
Dim lngK As Long


Sheets.Add after:=Sheets(1)
Sheets.Add after:=Sheets(1)
Sheets.Add after:=Sheets(1)
Sheets.Add after:=Sheets(1)
Sheets(2).Name = "остатки"
Sheets(3).Name = "Дебет"
Sheets(4).Name = "Кредит"
Sheets(5).Name = "Сводная таблица"

Call Copy_Data

Sheets(1).Activate
lngRow = 0

Do
lngRow = lngRow + 1
Loop Until IsNumeric(Left(Cells(lngRow, 1).Text, 5)) = True
'лист остатки
lastRow = lngRow
Do
lastRow = lastRow + 1
Loop Until InStr(1, Cells(lastRow, 2).Text, "ИТОГО")
'Stop
Range("A" + Trim(Str(lngRow)) + ":C" + Trim(Str(lastRow - 2))).Select
Selection.Copy
Sheets(2).Activate
ActiveSheet.Paste
Call AutoFitting
Sheets(1).Activate

'Лист Дебет
lngRow = lastRow + 1
lastRow = lngRow
Do
lastRow = lastRow + 1
Loop Until InStr(1, Cells(lastRow, 2).Text, "È Ò Î Ã Î")

Range("A" + Trim(Str(lngRow)) + ":C" + Trim(Str(lastRow - 2))).Select
Selection.Copy
Sheets(3).Activate
ActiveSheet.Paste
Call AutoFitting
Sheets(1).Activate
'лист Кредит
lngRow = lastRow + 1
lastRow = lngRow
Do
lastRow = lastRow + 1
Loop Until InStr(1, Cells(lastRow, 2).Text, "ИТОГО")

Range("A" + Trim(Str(lngRow)) + ":C" + Trim(Str(lastRow - 2))).Select
Selection.Copy
Sheets(4).Activate
ActiveSheet.Paste
Call AutoFitting
Sheets(1).Activate
Application.DisplayAlerts = False
Sheets(1).Delete

lastRow = 0

Do
' в лист 4 "Сводная таблица" из листа 1 "остатки" копируем одну строку
lastRow = lastRow + 1

Sheets(1).Rows(lastRow).Copy
Sheets(4).Select
Rows(lastRow + 4).Select
ActiveSheet.Paste
' Проверяем наличие такого же N счета на листах "Дебет" и "Кредит" и, в случае совпадения, копируем значение в нужный столбец, а саму строку удаляем
'лист ДЕБЕТ
lngD = 0
flagD = False
Do
lngD = lngD + 1
If Sheets(1).Cells(lastRow, 1).Text = Sheets(2).Cells(lngD, 1).Text Then
flagD = True
Sheets(4).Cells(lastRow + 4, 4).Value = Sheets(2).Cells(lngD, 3).Text
Sheets(2).Rows(lngD).Delete Shift:=xlUp
End If
Loop Until (Sheets(2).Cells(lngD, 1).Text = "") Or (flagD = True)
'ëèñò Êðåäèò
lngK = 0
flagK = False
Do
lngK = lngK + 1
If Sheets(1).Cells(lastRow, 1).Text = Sheets(3).Cells(lngK, 1).Text Then
flagK = True
Sheets(4).Cells(lastRow + 4, 5).Value = Sheets(3).Cells(lngK, 3).Text
Sheets(3).Rows(lngK).Delete Shift:=xlUp
End If
Loop Until (Sheets(3).Cells(lngK, 1).Text = "") Or (flagK = True)

Loop Until Sheets(1).Cells(lastRow, 1).Text = ""


End Sub

[Hugo121]

Чем вариант EugeneS не подошёл?
Мой тоже почти готов, самое трудное сделано...