Допустим, что каждое утро со всех отделов приходят отчёты - они консолодируются в одну книгу (кого интересует макрос- пишите), проводятся какието манипуляции с данными и после всего - нужно создавать на каждое отделение книгу со всей информацией , которая хранится в текущем файле и назвать файл номером отделения со столбца "А"
Уровень владения VBA - 6 дней (изменить свой же код - та еще задача) Что нужно изменть?)
№ BR
Product
Planned
Actual
Execution
1
Кредитный портфель
1 400 000
1 500 000
107,1%
1
Кредитный лимит
250 000
300 000
120,0%
1
Депозитный портфель
650 000
400 000
61,5%
1
Денежные переводы (шт.)
70
64
91,4%
2
Кредитный портфель
1 200 000
1 800 000
150,0%
2
Кредитний лимит
300 000
185 000
61,7%
2
Депозитный портфель
580 000
290 000
50,0%
2
Денежные переводы
65
54
83,1%
3
Кредитный портфель
1 350 000
850 000
63,0%
3
Кредитний лимит
250 000
280 000
112,0%
3
Депозитный портфель
400 000
340 000
85,0%
3
Денежные переводы
80
83
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, вы бы хоть книгу показали с 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
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