Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Макрос для суммирование значений в разных бланках
 
Всем привет,
Пытаюсь решить следующую задачку:
Есть файлы внутри которых указаны артикулы, кол-во к заказу и скидка, все файлы одного формата. Необходимо сделать макрос, который будет открывать поочередно каждый файл и копировать артикул - кол-во - скидка, если кол-во отлично от 0. Если есть возможность дописать название файла из которого он был подтянут было бы вообще супер.

Пример файла во вложении.

Спасибо.
 
Цитата
durango77 написал:
было бы вообще супер.
Если бы Вы приложили свои попытки , что то сделать.
"Все гениальное просто, а все простое гениально!!!"
 
Приложил, второй день пытаюсь разобраться. На данном этапе у меня открываются все файлы и суммируются данные по столбцу, но не могу привязать условия, которые мне необходимы.
Код
Sub SummAll()
Dim BazaWb As Workbook 'òåêóùàÿ êíèãà (îáùèé ôàéë)
Dim BazaSht As Worksheet 'ëèñò äëÿ ñóììû â îáùåì ôàéëå
Dim TempWb As Workbook 'ïî-î÷åð¸äíî îòêðûâàåìûé ôàéë
Dim TempSht As Worksheet 'ëèñò äëÿ ñóììû â ïî-î÷åð¸äíî îòêðûâàåìîì ôàéëåDim iTempFileName As String 'èìÿ ïî-î÷åð¸äíî îòêðûâàåìîãî ôàéëà
Dim iPath As String 'ïóòü ê ïàïêå, ãäå ëåæàò âñå ôàéëûDim iCol As Long 'ñòðîêà â ôàéëå
Dim iRow As Long 'ñòîëáåö â ôàéëå
Dim iRowTmp As Long 'ïîñëåäíÿÿ çàïîëíåííàÿ ñòðîêà â ôàéëå ïî ñòîëáöàì
Dim iColTmp As Long 'ïîñëåäíèé çàïîëíåííûé ñòîëáåö â  ôàéëå
Dim iNumFiles As Long 'êîëè÷åñòâî îòêðûâàåìûõ ôàéëîâ
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlManual
        Set BazaWb = ThisWorkbook
        Set BazaSht = BazaWb.ActiveSheet
        iPath = BazaWb.Path & "\"
        iTempFileName = Dir(iPath & "*.xls")
        
            'óäàëÿåì äàííûå ïåðåä ñóììèðîâàíèåì, åñëè íóæíî
            With BazaSht
                .Range(.Cells(2, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(1, Columns.Count).End(xlToLeft).Column)).ClearContents
            End With
      
        'ïî î÷åðåäè îòêðûâàåì ôàéëû èç ïàïêè
        Do While iTempFileName <> ""
            If iTempFileName <> BazaWb.Name Then
                Set TempWb = .Workbooks.Open _
                     (Filename:=iPath & iTempFileName, UpdateLinks:=False, ReadOnly:=True)
                     iNumFiles = iNumFiles + 1
                     Set TempSht = TempWb.ActiveSheet
                     
                     'Ðàáî÷àÿ êíèãà íå äîëæíà áûòü çàùèùåíà ïàðîëåì
                     With TempSht
                        'âñåãî ñòîëáöîâ â îòêðûòîì ëèñòå
                        iColTmp = .Cells(3, 13).End(xlToLeft).Column
                          
                            For iCol = 3 To iColTmp
                                'íîìåð ïîñëåäíåé çàïîëíåíîé ñòðîêè â ñòîëáöå
                                iRowTmp = .Cells(Rows.Count, 3).End(xlUp).Row
                                
                                    For iRow = 3 To iRowTmp
                                    
                                        BazaSht.Cells(iRow, iCol).Value = BazaSht.Cells(iRow, iCol).Value + .Cells(iRow, iCol).Value
                                    
                                    Next iRow
                                    
                            Next iCol
                         
                     End With
                     TempWb.Close saveChanges:=False
                
            End If
            iTempFileName = Dir
        Loop
        .Calculation = xlAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    MsgBox "Äàííûå îáðàáîòàíû èç " & iNumFiles & " ôàéëîâ!", vbInformation, "Êîíåö"
End Sub
Изменено: durango77 - 5 Дек 2018 19:44:49
 
Цитата
durango77 написал:
Есть файлы
Вот тут ключевое слово файлЫ. В примере я вижу полупустую таблицу, а вот чем заполнять не вижу. Попробуйте на чужом АРМе открыть свою тему и решить задачу с теми данными которые представлены.
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim,
Пример не пустой и заполнять его не нужно. Нужно скопировать только те артикулы, которые имеет кол-во отличное от 0.
 
Цитата
durango77 написал:
Нужно скопировать только те артикулы
Куда скопировать?
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim,
В активный лист книги из которой будет запускаться макрос.
 
Код
Sub test()
    Dim iPath$, lrow&, arr(), fname$
    Dim sht As Worksheet, i&, j&, k&
    iPath = "Путь" & Application.PathSeparator
    Set sht = ThisWorkbook.Worksheets(1)
    fname = Dir(iPath & "*.xls*")
    Do Until fname = ""
        k = 0
        With GetObject(iPath & fname)
            arr = .ActiveSheet.[a2].CurrentRegion.Value
            .Close False
        End With
        lrow = sht.Range("a" & sht.Rows.Count).End(xlUp).Row + 1
        For i = 3 To UBound(arr)
            If arr(i, 3) > 0 Then
                k = k + 1
                For j = 2 To UBound(arr, 2)
                    arr(k, j) = arr(i, j)
                Next j
                arr(k, 1) = fname
            End If
        Next i
        sht.Range("a" & lrow).Resize(k, UBound(arr, 2)) = arr
        fname = Dir
    Loop
    sht.[a1].Resize(, 4) = Array("Имя файла", "арт.", "кол-во", "% скидки")
    sht.UsedRange.Columns.AutoFit
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim,
Спасибо, у меня макрос закрывает все листы после повторения цикла, если ограничить выполнения до Loop, то все работает.\
Подскажите, плз, как ограничить кол-во столбцов, чтобы он не подтягивал информацию после 6 столбца.

Спасибо.
 
Цитата
durango77 написал:
у меня макрос закрывает все листы после повторения цикла, если ограничить выполнения до Loop, то все работает.
Он их фактически и не открывает, как обычно, так и было задумано.
Цитата
durango77 написал:как ограничить кол-во столбцов
а зачем?
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
durango77 написал:
если ограничить выполнения до Loop
То не все файлы будут обработаны.
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim,
Я имею ввиду, что закрывает ту книгу из которого был запущен макрос. Т.е. после суммирования всех файлов я имею закрытый excel

По поводу столбцов, некоторые файлы содержат лишнюю инфу, но некритично.
 
Уберите книгу из папки с файлами или поставьте проверку на то если
Код
If fname <> ThisWorkbook.Name Then
'код после Do
End If ' перед fname = Dir
"Все гениальное просто, а все простое гениально!!!"
 
Спасибо за помощь. Осталось только отрезать 6 колонок
 
Цитата
durango77 написал:
Осталось только отрезать 6 колонок
Попробуйте так:
Перед End Sub dcnfdmnt:    
Код
cDel = sht.UsedRange.Columns.Count          ' подсчитаем не пустые колонки
  If cDel > 4 Then ActiveSheet.Columns("e:aa").Delete

Где "e:aa" - колонки, начиная с 4-й, которые удаляем  
Изменено: pitby - 5 Дек 2018 18:00:59
 
Цитата
durango77 написал: Осталось только отрезать 6 колонок
Никак не пойму в чем фишка брать только 6 колонок чем остальные помешали?
Код
sht.Range("a" & lrow).Resize(k,6) = arr
Должно помочь.
Изменено: Nordheim - 5 Дек 2018 19:45:37
"Все гениальное просто, а все простое гениально!!!"
 
Скорее всего, в остальных колонках есть информация, не нужная для копирования.
 
Цитата
Nordheim написал:
sht.Range("a" & lrow).Resize(k,6) = arr
Nordheim, подскажите, как записать это выражение для копирования определённых столбцов?
Например, с 1 по 6, 9, 10, 12-18 и т.д?
 
Наверно так
Код
Sub test()
    Dim iPath$, lrow&, arr(), fname$
    Dim sht As Worksheet, i&, j&, k&, l&
    iPath = "Путь" & Application.PathSeparator
    Set sht = ThisWorkbook.Worksheets(1)
    fname = Dir(iPath & "*.xls*")
    Do Until fname = ""
        k = 0
        With GetObject(iPath & fname)
            arr = .ActiveSheet.[a2].CurrentRegion.Value
            .Close False
        End With
        lrow = sht.Range("a" & sht.Rows.Count).End(xlUp).Row + 1
        For i = 3 To UBound(arr)
            If arr(i, 3) > 0 Then
                k = k + 1: l = 0
                For j = 2 To UBound(arr, 2)
                    Select Case j
                        Case 1 To 6, 9, 10, 12 To 18
                            l = l + 1
                            arr(k, l) = arr(i, j)
                    End Select
                Next j
                arr(k, 1) = fname
            End If
        Next i
        sht.Range("a" & lrow).Resize(k, l) = arr
        fname = Dir
    Loop
    sht.[a1].Resize(, 4) = Array("Имя файла", "арт.", "кол-во", "% скидки")
    sht.UsedRange.Columns.AutoFit
End Sub
Изменено: Nordheim - 6 Дек 2018 09:55:39
"Все гениальное просто, а все простое гениально!!!"
 
pitby, В вашем выражении переносится массив (часть массива) на лист, если из массива нужно перенести определенные столбцы, то тут нужен цикл
либо из искомого массива перенести нужные столбцы при помощи Select Case ... End Select , как я показал в предыдущем сообщении.
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
Nordheim написал:
как я показал в предыдущем сообщении.
Спасибо, буду разбираться.
Страницы: 1
Читают тему (гостей: 2)
Наверх