Страницы: 1
RSS
Цикл создания новых книг на основании инфорамации с текущего файла VBA
 
Всем привет!

Ситуация такова :

Допустим, что каждое утро  со всех отделов приходят отчёты -  они консолодируются в одну книгу (кого  интересует макрос- пишите), проводятся какието манипуляции с данными и после всего -   нужно создавать на каждое отделение книгу со всей информацией  , которая хранится в текущем файле и назвать файл номером  отделения со столбца "А"

Уровень владения VBA - 6 дней    (изменить свой же код - та еще задача)
Что нужно изменть?)
№ BRProduct                               Planned  Actual     Execution
1        Кредитный портфель       1 400 0001 500 000 107,1%  
1        Кредитный лимит             250 000   300 000   120,0%  
1        Депозитный портфель     650 000   400 000   61,5%    
1         Денежные переводы (шт.)7064 91,4%
2        Кредитный портфель1 200 0001 800 000 150,0%
2        Кредитний лимит 300 000185 000 61,7%
2        Депозитный портфель580 000290 000 50,0%
2        Денежные переводы 6554 83,1%
3        Кредитный портфель1 350 000850 000 63,0%
3        Кредитний лимит 250 000280 000 112,0%
3        Депозитный портфель400 000340 000 85,0%
3        Денежные переводы        8083 103,8%
Код
Sub drop()
 
Dim sFolder As String, sFiles As String
Dim i As Long, LR As Long, RV As String
    
    With Application.FileDialog(msoFileDialogFolderPicker) 'диалоговое окно , с его помощью определяем место сохранения файлов
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
       
      
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator) 
 
    LR = Cells(Rows.Count, 1).End(xlUp).Row ' определяет последнюю ячейку со значениями в колонке
    For i = 2 To LR Step 4] ' каждые 4 строки начиная со 2 по LR
         RV = Cells(i, 1) 'номер отделения
         Workbooks.Add ' создаёт файл 
 
      'НЕ РАБОТАЕТ
 
         ThisWorkbook.Sheets(1).Cells(i, 4).Copy Destination: = ActiveWorkbook.Sheets(1).Range("B2:B5")  'копирует и вставляет значения
         ActiveWorkbook.SaveAs Filename:=Dir(sFolder & "BR " & RV & " Execution" & ".xls") ' присваивает имя
         ActiveWorkbook.Close True 'закрывает и сохраняет 
    Next i
           
   
End Sub
Изменено: Gnaeus Pompeius - 14.04.2021 21:32:11
 
Gnaeus Pompeius, вы бы хоть книгу показали с 5-10 строк данных...
Код
Sub drop()
Dim sFolder As String, sFiles As String
Dim i As Long, LR As Long, RV As String
    With Application.FileDialog(msoFileDialogFolderPicker) 'диалоговое окно , с его помощью определяем место сохранения файлов
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With       
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    LR = Cells(Rows.Count, 1).End(xlUp).Row ' определяет последнюю ячейку со значениями в колонке
    For i = 2 To LR Step 4  ' каждые 4 строки начиная со 2 по LR
         RV = Cells(i, 1) 'номер отделения
         Workbooks.Add ' создаёт файл
         ThisWorkbook.Sheets(1).Range(Cells(i, 1), Cells(i + 3, 3)).Copy Destination:=ActiveWorkbook.Sheets(1).Range("B2")   'копирует и вставляет значения
        ActiveWorkbook.SaveAs Filename:=sFolder & "BR " & RV & " Execution", FileFormat:=xlWorkbookNormal
         ActiveWorkbook.Close True 'закрывает и сохраняет
    Next i           
End Sub
Изменено: Mershik - 14.04.2021 21:31:46
Не бойтесь совершенства. Вам его не достичь.
 
в xlsx макросы не живут(((
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
возможно пригодится
Код
Sub AutoFilling()
 
    Dim sFolder As String, sFiles As String
    Dim WB As Workbook
    Dim i As Long, LR As Long, RV As String
   
   'ijàëîãîâå â³êíî çàïèòó ïàïêè ñ ôàéëàìè
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    Application.ScreenUpdating = False  'â³äêëþ÷åííÿ îíîâëåííÿ åêðàíó, ùîá íå çàâàæàëè â³êíà ïðîöåñ³â
   'Öèêë çàïóñêó ôàéë³â
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        Set WB = Application.Workbooks.Open(sFolder & sFiles)
        WB.Windows(1).Visible = False  'çãîðòຠîáðàíèé ôàéë. Çàäëÿ çðó÷íîñò³ ïðè ðó÷íîìó òåñòóâàíí³, ùîá íå çãîðòàòè ôàéë âëàñíîðó÷
          'Öèêë ïîøóêó ä³àïàçîíó äëÿ ï³äñòàíîâêè
           LR = Cells(Rows.Count, 1).End(xlUp).Row
           For i = 2 To LR Step 4  'ðîçì³ð êðîêó çàëåæèòü â³ä ê³ëüêîñò³ ïîêàçíèê³â
              RV = Cells(i, 1)
              BR = Split(Split(WB.Name, " ")(2), ".")(0)
                If ThisWorkbook.Sheets(1).Range("D1").Value <> "Actual" Then
                   ThisWorkbook.Sheets(1).Range("D1").Value = "Actual"
                End If
                If RV = BR Then
                   WB.Sheets(1).Range("B2:B5").Copy Destination:=ThisWorkbook.Sheets(1).Cells(i, 4): Exit For 'âíåñåííÿ ôàêòè÷íèõ ïîêàçíèê³â
                End If
           Next i
        WB.Close False  'çàêðèâຠêíèãó áåç çáåðåæåííÿ
        sFiles = Dir
    Loop
   'Ðîçðàõóíîê â³äñîòêó âèêîíàííÿ ïëàíó
    Range("A1").End(xlDown).End(xlToRight).Offset(0, 1).Select
    With Range(Selection, Selection.End(xlUp).Offset(1, 0))
        .Formula = "=D2/C2"
        .NumberFormat = "0.0%"
        .Copy
        .PasteSpecial Paste:=xlPasteValues   'ïåðåòâîðåííÿ ôîðìóë â çíà÷åííÿ çàäëÿ ïîëåãøåííÿ ïîäàëüøî¿ ðîáîòè ç³ çíà÷åííÿìè
      End With
    With Selection.End(xlUp).End(xlUp)
      If .Value <> "Execution" Then
         .Value = "Execution"
      End If
     .Font.Bold = True
    Application.ScreenUpdating = True  'àêòèâóº îíîâëåííÿ åêðàíó
    End With


End Sub
Страницы: 1
Наверх