Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA.Сводная таблица, Макросом с листов с названиями месяцев данные отправить в лист «свод», в котором в ячейке А1 список с выбором месяца
 
#1
17.05.2024 11:25:29

Уважаемые ГУРУ VBA!  Помогите пожалуйста дерзкому новичку. Я перечитала массу уроков и форумов, пыталась собрать из кусочков кодов решение моей задачки. То что нужно – не получается! Смысл задачи таков:  Ежемесячно учреждения (их у меня 86) присылают отчеты. Я их (макросом) собираю в отдельный файл на один лист, этот лист я копирую вручную в СВОД.

В моем примере есть листы с названиями месяцев и из них данные должны попасть в лист «свод» в соответствующие столбцы, в котором в ячейке А1 список с выбором месяца.

Эту задачу я давно сделала с помощью формул, но файл получается невероятно тормозной.

Я прикладываю модель моей таблицы. (набором кусочков кодов, с которыми я эксперементировала, засорять пространство не стала)

Помогите пожалуйста с решением!
 
 
 
#2
17.05.2024 11:30:21
решение с помощью Power Query не рассматривали? Мне кажется это более подходящий инструмент для такой задачи. Файл не смотрел
 
 
 
#3
17.05.2024 11:35:27
надстройка Power Query у большинства пользователей этого свода не может быть установлена, к моему сожалению
 
 
 
#4
17.05.2024 11:53:06
Код
Sub FillSheet()
    Dim arr As Variant
    arr = GetArrFromSheet(Sheets("свод").Range("A1"))
    If Not IsEmpty(arr) Then
        myPrint Sheets("свод").Range("B3"), arr
    End If
End Sub

Private Sub myPrint(rr As Range, arr As Variant)
    rr.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

Private Function GetArrFromSheet(sheetName As String) As Variant
    Dim sh As Worksheet
    On Error Resume Next
    Set sh = Sheets(sheetName)
    On Error GoTo 0
    If sh Is Nothing Then
        MsgBox "Нет листа " & sheetName, vbCritical, "Заполнение листа"
    Else
        GetArrFromSheet = GetArrFromRange(sh.Cells(2, 1).Resize(sh.UsedRange.Rows.Count, 4))
    End If
End Function

Private Function GetArrFromRange(rr As Range) As Variant
    Dim yb As Long
    Dim xb As Long
    yb = Application.Max(rr.Columns(1))
    xb = Application.Max(rr.Columns(2))
    
    If yb = 0 Then Exit Function
    If xb = 0 Then Exit Function
    
    Dim arr As Variant
    arr = rr.Value
    
    Dim brr As Variant
    ReDim brr(1 To yb, 1 To xb)
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If IsNumeric(arr(ya, 1)) Then
            yb = arr(ya, 1)
            If yb > 0 Then
                If IsNumeric(arr(ya, 2)) Then
                    xb = arr(ya, 2)
                    If xb > 0 Then
                        If IsNumeric(arr(ya, 4)) Then
                            brr(yb, xb) = brr(yb, xb) + arr(ya, 4)
                        End If
                    End If
                End If
            End If
        End If
    Next
    GetArrFromRange = brr
End Function
Я бы убрал "сводная таблица" из названия. В Excel под этим подразумевается определённый инструмент.
 
 
 
#5
17.05.2024 11:53:32
Цитата
Татьяна Ляшецкая написал:
надстройка Power Query у большинства пользователей этого свода не может быть установлена, к моему сожалению
эксель какого года Вы используете? С 2013-ого Power Query встроена по умолчанию в Excel.
 
 
 
#6
17.05.2024 13:34:08
У нас самый новый эксель 2010
 
 
 
#7
17.05.2024 13:38:34
ВООБЩЕ! МатросНаЗебре, Вы Волшебник! Вы меня спасли! :-)
 
 
 
#8
17.05.2024 13:41:07
Ой! Простите за настойчивость, а как привязать выбор месяца из Ячейки свод!А1 ?
 
 
 
#9
17.05.2024 13:43:28
Простите! ВСЁ работает! Спасибо ещё раз!
 
 
 
#10
17.05.2024 14:23:10
Добавьте магии своему проекту. Вставьте код в модуль листа "свод".
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0, xlA1) = "A1" Then FillSheet
End Sub
Измените значение в ячейке A1.
 
 
 
#11
17.05.2024 14:33:20
МатросНаЗебре, Вы Гений ! Спасибо!
 
 
 
#12
20.05.2024 12:55:44
Здравствуйте! Макрос отличный, все работает, но у меня "засада" с номерами учреждений. Учреждения в этой таблице расположены по типу учреждения, т.е. номера будут не подряд. Можно сделать так, чтобы данные распределялись в зависимости от номера учреждения?
 
 
 
#13
20.05.2024 13:01:01
Только от номера и зависит. Не зависит от расположения подряд.
 
 
 
#14
20.05.2024 13:05:05
Если я в столбце А меняю очередность номеров, загружаемые данные порядок не меняют, а должны
Изменено: Татьяна Ляшецкая - 20.05.2024 13:05:30
 
 
 
#15
20.05.2024 13:16:11
Загружаемые данные привязаны к конкретному учреждению
 
 
 
#16
20.05.2024 13:49:15
Код
Option Explicit

Private dicY As Object
Private dicX As Object
Private printCell As Range

Sub FillSheet()
    Dim svod As Worksheet
    Set svod = Sheets("свод")
    
    Set printCell = svod.Range("B3")
    
    Set dicY = GetDic(svod.UsedRange.Columns(1), True)
    Set dicX = GetDic(svod.UsedRange.Rows(1), False)
    
    Dim arr As Variant
    arr = GetArrFromSheet(svod.Range("A1"))
    If Not IsEmpty(arr) Then
        myPrint printCell, arr
    End If
End Sub

Private Function GetDic(rr As Range, rowMode As Boolean) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim cl As Range
    For Each cl In rr.Cells
        dic.Item(cl.Value) = IIf(rowMode, cl.Row - printCell.Row, cl.Column - printCell.Column) + 1
        If dic.Item(cl.Value) <= 0 Then dic.Remove cl.Value
    Next
    
    Set GetDic = dic
End Function

Private Sub myPrint(rr As Range, arr As Variant)
    rr.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

Private Function GetArrFromSheet(sheetName As String) As Variant
    Dim sh As Worksheet
    On Error Resume Next
    Set sh = Sheets(sheetName)
    On Error GoTo 0
    If sh Is Nothing Then
        MsgBox "Нет листа " & sheetName, vbCritical, "Заполнение листа"
    Else
        GetArrFromSheet = GetArrFromRange(sh.Cells(2, 1).Resize(sh.UsedRange.Rows.Count, 4))
    End If
End Function

Private Function GetArrFromRange(rr As Range) As Variant
    Dim yb As Long
    Dim xb As Long
'    yb = Application.Max(rr.Columns(1))
'    xb = Application.Max(rr.Columns(2))
    yb = dicY.Items()(dicY.Count - 1)
    xb = dicX.Items()(dicX.Count - 1)
    
    If yb = 0 Then Exit Function
    If xb = 0 Then Exit Function
    
    Dim arr As Variant
    arr = rr.Value
    
    Dim brr As Variant
    ReDim brr(1 To yb, 1 To xb)
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If dicY.Exists(arr(ya, 1)) Then
            yb = dicY.Item(arr(ya, 1))
            If yb > 0 Then
                If dicX.Exists(arr(ya, 2)) Then
                    xb = dicX.Item(arr(ya, 2))
                    If xb > 0 Then
                        If IsNumeric(arr(ya, 4)) Then
                            brr(yb, xb) = brr(yb, xb) + arr(ya, 4)
                        End If
                    End If
                End If
            End If
        End If
    Next
    GetArrFromRange = brr
End Function
 
 
 
#17
20.05.2024 15:13:58
Спасибо ОГРОМНОЕ!
 
 
 
Страницы: 1
Наверх