Добрый вечер, уважаемые гуру форума! Совсем недавно начал серьезно изучать vba, так как рутинной работы прибавляется изо дня в день всё больше и больше.... Но без Вашей помощи еще никак не могу обойтись. Есть Книга1 и Книга2. Эти книги формируются путем выгрузки данных из разных программ. Также есть Сводная книга, в которую я копирую данные. В сводной книге в столбец "Книга1" соответственно улице и дому копирую номера квартир, в столбец "Книга2" также копирую номера квартир соответственно улице и дому, но если есть условие (на пример есть условие по Пушкина 48-12), то эту квартиру (точнее номер квартиры "12") уже не копирую. Есть еще одно условие - названия улиц, а так же номера домов могут идти в разнобой, т.е. в одном месяце сначала идет улица Пушкина, потом, на пример, Некрасова. В следующем месяце улица Некрасова может идти первой, а улица Пушкина - позже. Так же "плясать" могут и номера домов.... В одном месяце 46-ой дом Пушкина может идти первым, а в следующем месяце - 56-ой дом, затем 46-ой и т.д. Единственное, что не меняется в этом кошмаре, так это Сводная книга - там улицы и номера домов, расположение столбцов не меняется. Подскажите, пожалуйста, возможно ли как-то автоматизировать процесс копирования из Книг1-2 в Сводную таблицу? Заранее большое спасибо! P.S. Структура Книг1-2 всегда одинакова.
Добрый вечер, уважаемые гуру форума! Совсем недавно начал серьезно изучать vba, так как рутинной работы прибавляется изо дня в день всё больше и больше.... Но без Вашей помощи еще никак не могу обойтись. Есть Книга1 и Книга2. Эти книги формируются путем выгрузки данных из разных программ. Также есть Сводная книга, в которую я копирую данные. В сводной книге в столбец "Книга1" соответственно улице и дому копирую номера квартир, в столбец "Книга2" также копирую номера квартир соответственно улице и дому, но если есть условие (на пример есть условие по Пушкина 48-12), то эту квартиру (точнее номер квартиры "12") уже не копирую. Есть еще одно условие - названия улиц, а так же номера домов могут идти в разнобой, т.е. в одном месяце сначала идет улица Пушкина, потом, на пример, Некрасова. В следующем месяце улица Некрасова может идти первой, а улица Пушкина - позже. Так же "плясать" могут и номера домов.... В одном месяце 46-ой дом Пушкина может идти первым, а в следующем месяце - 56-ой дом, затем 46-ой и т.д. Единственное, что не меняется в этом кошмаре, так это Сводная книга - там улицы и номера домов, расположение столбцов не меняется. Подскажите, пожалуйста, возможно ли как-то автоматизировать процесс копирования из Книг1-2 в Сводную таблицу? Заранее большое спасибо! P.S. Структура Книг1-2 всегда одинакова.Leojse
Здравствуйте а если в сводной книге уже есть номер квартиры для соответствующих улицы и дома, то такую квартиру уже не копируем из Книга1 или Книга2?
Здравствуйте а если в сводной книге уже есть номер квартиры для соответствующих улицы и дома, то такую квартиру уже не копируем из Книга1 или Книга2?nilem
nilem, здравствуйте! Дело в том, что после копирования Книг1-2 в Сводную, я отпечатываю отчет и очищаю Сводную. Перед новым копированием Сводная книга всегда чистая.
nilem, здравствуйте! Дело в том, что после копирования Книг1-2 в Сводную, я отпечатываю отчет и очищаю Сводную. Перед новым копированием Сводная книга всегда чистая.Leojse
Sub ertert() Dim y(), i&, k&, s$, r Application.ScreenUpdating = False
x = Range("B1").CurrentRegion.Value ReDim y(1 To 1000, 1 To UBound(x, 2)) ReDim r(1 To UBound(x, 2))
With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x, 2) Step 2 .Item(x(1, i) & x(1, i + 1)) = i Next i
Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга1.xlsx]Лист1'!A8:D10000)" For i = 1 To UBound(x) If IsEmpty(x(i, 2)) Then Exit For If Len(x(i, 1)) = 0 Then s = x(i, 2) & x(i, 3) If .Exists(s) Then k = .Item(s): r(k) = r(k) + 1: y(r(k), k) = x(i, 4) End If Next i
Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга2.xlsx]Лист1'!D4:G10000)" For i = 1 To UBound(x) If IsEmpty(x(i, 2)) Then Exit For If Len(x(i, 1)) = 0 Then s = x(i, 2) & x(i, 3) If .Exists(s) Then k = .Item(s) + 1: r(k) = r(k) + 1: y(r(k), k) = x(i, 4) End If Next i End With Range("A1").Formula = Empty Range("B3").Resize(UBound(y, 1), UBound(y, 2)).Value = y Application.ScreenUpdating = True End Sub
Private Function ToArray(ref) x = ref End Function
Sub ertert() Dim y(), i&, k&, s$, r Application.ScreenUpdating = False
x = Range("B1").CurrentRegion.Value ReDim y(1 To 1000, 1 To UBound(x, 2)) ReDim r(1 To UBound(x, 2))
With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x, 2) Step 2 .Item(x(1, i) & x(1, i + 1)) = i Next i
Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга1.xlsx]Лист1'!A8:D10000)" For i = 1 To UBound(x) If IsEmpty(x(i, 2)) Then Exit For If Len(x(i, 1)) = 0 Then s = x(i, 2) & x(i, 3) If .Exists(s) Then k = .Item(s): r(k) = r(k) + 1: y(r(k), k) = x(i, 4) End If Next i
Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга2.xlsx]Лист1'!D4:G10000)" For i = 1 To UBound(x) If IsEmpty(x(i, 2)) Then Exit For If Len(x(i, 1)) = 0 Then s = x(i, 2) & x(i, 3) If .Exists(s) Then k = .Item(s) + 1: r(k) = r(k) + 1: y(r(k), k) = x(i, 4) End If Next i End With Range("A1").Formula = Empty Range("B3").Resize(UBound(y, 1), UBound(y, 2)).Value = y Application.ScreenUpdating = True End Sub
Private Function ToArray(ref) x = ref End Function
Добрый день. Вышеуказанный макрос отрабатывается на выложенном мной примере на ура, но на рабочих файлах никак не хочет собирать данные. Пробовал менять типы переменных, смотрел различные свойства, менял форматы ячеек, но никак не получается - еще мало что понимаю в vba. Либо ничего не собирается, либо out of range, либо метод/свойство не поддерживается... Поэтому снова прошу Вас о помощи. Прикладываю максимально похожие примеры на рабочие файлы.
Добрый день. Вышеуказанный макрос отрабатывается на выложенном мной примере на ура, но на рабочих файлах никак не хочет собирать данные. Пробовал менять типы переменных, смотрел различные свойства, менял форматы ячеек, но никак не получается - еще мало что понимаю в vba. Либо ничего не собирается, либо out of range, либо метод/свойство не поддерживается... Поэтому снова прошу Вас о помощи. Прикладываю максимально похожие примеры на рабочие файлы.Leojse
Sub ertert() Dim y(), i&, k&, s$, r Application.ScreenUpdating = False
x = Range("B1").CurrentRegion.Value ReDim y(1 To 1000, 1 To UBound(x, 2)) ReDim r(1 To UBound(x, 2)): Range("A1").Formula = Empty
With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x, 2) Step 2 .Item(Trim(x(1, i)) & Trim(x(1, i + 1))) = i Next i
Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга1.xlsx]Лист1'!A6:D10000)" 'данные начинаются с 6-й строки For i = 1 To UBound(x) If IsEmpty(x(i, 2)) Then Exit For
' If Len(x(i, 1)) = 0 Then'теперь условие для Книга1 не проверяем, т.е. его просто нет s = Trim(x(i, 2)) & Trim(x(i, 3)) If .Exists(s) Then k = .Item(s): r(k) = r(k) + 1: y(r(k), k) = x(i, 4) ' End If Next i
Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга2.xls]Лист1'!D4:G10000)" 'Книга2.xls - Книга2 оказалась в формате Ексель 2003 For i = 1 To UBound(x) If IsEmpty(x(i, 2)) Then Exit For If Len(x(i, 1)) = 0 Then s = Trim(x(i, 2)) & Trim(x(i, 3)) 'везде добавляем Trim, т.к. какой-то коварный враг наставил пробелов в данных If .Exists(s) Then k = .Item(s) + 1: r(k) = r(k) + 1: y(r(k), k) = x(i, 4) End If Next i End With Range("A1").Formula = Empty Range("B3").Resize(UBound(y, 1), UBound(y, 2)).Value = y Application.ScreenUpdating = True End Sub
Private Function ToArray(ref) x = ref End Function
[/vba]
в измененных строках написал комментарии [vba]
Код
Option Explicit Dim x
Sub ertert() Dim y(), i&, k&, s$, r Application.ScreenUpdating = False
x = Range("B1").CurrentRegion.Value ReDim y(1 To 1000, 1 To UBound(x, 2)) ReDim r(1 To UBound(x, 2)): Range("A1").Formula = Empty
With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x, 2) Step 2 .Item(Trim(x(1, i)) & Trim(x(1, i + 1))) = i Next i
Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга1.xlsx]Лист1'!A6:D10000)" 'данные начинаются с 6-й строки For i = 1 To UBound(x) If IsEmpty(x(i, 2)) Then Exit For
' If Len(x(i, 1)) = 0 Then'теперь условие для Книга1 не проверяем, т.е. его просто нет s = Trim(x(i, 2)) & Trim(x(i, 3)) If .Exists(s) Then k = .Item(s): r(k) = r(k) + 1: y(r(k), k) = x(i, 4) ' End If Next i
Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга2.xls]Лист1'!D4:G10000)" 'Книга2.xls - Книга2 оказалась в формате Ексель 2003 For i = 1 To UBound(x) If IsEmpty(x(i, 2)) Then Exit For If Len(x(i, 1)) = 0 Then s = Trim(x(i, 2)) & Trim(x(i, 3)) 'везде добавляем Trim, т.к. какой-то коварный враг наставил пробелов в данных If .Exists(s) Then k = .Item(s) + 1: r(k) = r(k) + 1: y(r(k), k) = x(i, 4) End If Next i End With Range("A1").Formula = Empty Range("B3").Resize(UBound(y, 1), UBound(y, 2)).Value = y Application.ScreenUpdating = True End Sub
Private Function ToArray(ref) x = ref End Function
nilem, снова прошу у Вас помощи. В долгу не останусь, обязательно отблагодарю! Подскажите, пожалуйста, как в макросе сделать так, чтобы при обработке данных не копировались номера квартир в сводную, если есть условие в книге1?
nilem, снова прошу у Вас помощи. В долгу не останусь, обязательно отблагодарю! Подскажите, пожалуйста, как в макросе сделать так, чтобы при обработке данных не копировались номера квартир в сводную, если есть условие в книге1?Leojse