Этот раздел:
' need to change to appropriate files
Windows(new_wb).Activate
Dim A2 As Integer
A2 = 20
For A2 = 0 To A2 Step 1
If SheetExists("Sheet:" & A2) Then
Sheets("Sheet:" & A2).Select
Exit For
End If
Next
не имеет смысла (по крайней мере для меня).
- Вы ищете лист с именем между
"Sheet:0"и "Sheet:20".Но (при условии, что я понял предыдущий код) рабочая книга (с именем new_wb) на тот момент будет содержать только 2 листа;а именно ALL и все, что Adviser.Text оценивается до. - Если условие внутри цикла
For всегда False, ваш код не активирует рабочий лист, в который вы хотите вставить - то есть выВероятно, вы перейдете к вставке на тот лист, который был активен до цикла For. - Было бы хорошо поместить этот раздел в функцию, которая возвращает лист.Таким образом он возвращает либо
Worksheet, либо Nothing - и исключается возможность его молчаливого сбоя. - Вы объявляете переменные
A1 и A2, но внутри обоих циклов For выиспользуйте только A2.Возможно, это преднамеренно, или вы скопировали и забыли обновить.
created, кажется, флаг, указывающий, создавать ли новую рабочую книгу во время текущейитерация циклаКажется, это всего лишь одно из двух значений в коде (1 или 0), поэтому его лучше объявить как тип Boolean. - Однако, если вы отложите / переместите созданиеновая рабочая книга после проверки
If (ActiveWindow.RangeSelection.Rows.count < 4000) Then, вы можете полностью избавиться от переменной created?Логически я думаю, что это будет означать, что новая книга будет создана, только если условие If равно True.
Я не проверял приведенный ниже код, но если вы делаете копииваши работы / файлы до запуска процедуры Macro1, тогда это может дать вам некоторое представление о том, как добиться того, чего вы хотите.Он не будет точно таким же, как ваш код, так как некоторые вещи я удалил.
Вы можете шаг за шагом проходить через него с F8 или Shift+F8.Установка точек останова с помощью F9 также полезна.
Private Function AddSheetToWorkbook(ByVal targetBook As Workbook, ByVal sheetName As String, Optional sheetIndexToUse As Long = 0) As Worksheet
' Either adds a new worksheet or uses existing sheet if sheetIndexToUse was provided.
Dim targetSheet As Worksheet
If sheetIndexToUse < 1 Then
Set targetSheet = targetBook.Worksheets.Add
Else
Set targetSheet = targetBook.Worksheets(sheetIndexToUse) ' Will raise error if sheetIndex > Worksheets.Count
End If
targetSheet.Name = sheetName
Set AddSheetToWorkbook = targetSheet
End Function
Private Function CreateAllSheet(ByVal targetBook As Workbook) As Worksheet
Set CreateAllSheet = AddSheetToWorkbook(targetBook, sheetName:="ALL", sheetIndexToUse:=1)
End Function
Private Function CreateAdviserSheet(ByVal targetBook As Workbook, ByVal Adviser As String) As Worksheet
Set CreateAdviserSheet = AddSheetToWorkbook(targetBook, sheetName:=Adviser)
End Function
Private Function CreateCountSheet(ByVal targetBook As Workbook) As Worksheet
Set CreateCountSheet = AddSheetToWorkbook(targetBook, sheetName:="Count")
End Function
Private Function GetLastRow(ByVal targetSheet As Worksheet, Optional ByVal columnToUse As Variant = "A") As Long
GetLastRow = targetSheet.Cells(targetSheet.Rows.Count, columnToUse).End(xlUp).Row
End Function
Private Function GetLastColumn(ByVal targetSheet As Worksheet, Optional ByVal rowToUse As Long = 1) As Long
GetLastColumn = targetSheet.Cells(rowToUse, targetSheet.Columns.Count).End(xlToRight).Column
End Function
Private Function GetLastCell(ByVal targetSheet As Worksheet) As Range
Dim lastRow As Long
lastRow = GetLastRow(targetSheet)
Dim lastColumn As Long
lastColumn = GetLastColumn(targetSheet)
Set GetLastCell = targetSheet.Cells(lastRow, lastColumn)
End Function
Private Function GetRowsMatchingCriteria(ByVal targetSheet As Worksheet, ByVal targetField As Long, ByVal Criterion As String)
Dim includingHeaders As Range
Set includingHeaders = targetSheet.Range("A1", GetLastCell(targetSheet))
With includingHeaders
.AutoFilter
.AutoFilter Field:=targetField, Criteria1:=Criterion
On Error Resume Next
Set GetRowsMatchingCriteria = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
End With
End Function
Private Function GetRowsMatchingDept(ByVal targetSheet As Worksheet, ByVal Dept As String) As Range
Set GetRowsMatchingDept = GetRowsMatchingCriteria(targetSheet, targetField:=60, Criterion:=Dept)
End Function
Private Function GetRowsMatchingAdviser(ByVal targetSheet As Worksheet, ByVal Adviser As String) As Range
Set GetRowsMatchingAdviser = GetRowsMatchingCriteria(targetSheet, targetField:=61, Criterion:=Adviser)
End Function
Private Sub AdjustRowAndColumnWidths(ByVal targetSheet As Worksheet)
With targetSheet.Range("A1", GetLastCell(targetSheet))
.RowHeight = 12.75
.EntireColumn.AutoFit
End With
End Sub
Private Sub SortSheetContents(ByVal targetSheet As Worksheet)
'sort records by dept, then by adv_name, then by id
With targetSheet
.Range("A2").Sort Key1:=.Range("BH1"), _
Key2:=.Range("BI1"), Key3:=.Range("C1"), _
Header:=xlYes
End With
End Sub
Private Sub CopyDataToSheetAndFormat(ByVal rangeToCopy As Range, ByVal topLeftPasteCell As Range)
' Copies data to a sheet, formats and sorts.
Dim destinationSheet As Worksheet
Set destinationSheet = topLeftPasteCell.Parent
rangeToCopy.Copy Destination:=topLeftPasteCell
AdjustRowAndColumnWidths targetSheet:=destinationSheet
SortSheetContents targetSheet:=destinationSheet
End Sub
Private Sub AddBordersToAdviserSheet(ByVal adviserSheet As Worksheet)
'place the neccessary borders (seperators)
'31 is the number of the Major_code column
Const MAJOR_CODE_COLUMN_INDEX As Long = 31
Dim lastRow As Long
lastRow = GetLastRow(adviserSheet, MAJOR_CODE_COLUMN_INDEX)
With adviserSheet
Dim targetRange As Range
Set targetRange = .Range(.Cells(2, MAJOR_CODE_COLUMN_INDEX), .Cells(lastRow, MAJOR_CODE_COLUMN_INDEX))
End With
Debug.Assert targetRange.Columns.Count = 1
Dim cell As Range
For Each cell In targetRange
If cell.Value <> cell.Offset(1).Value Then
' Might be better to work from sheet's last column to left
' or working out last column before entering loop.
adviserSheet.Range(cell, cell.End(xlToRight)).Borders(xlEdgeBottom).Weight = xlMedium
End If
Next cell
End Sub
Private Function GetDataWorksheet() As Worksheet
Dim folderPath As String
folderPath = ThisWorkbook.Path & "\"
Dim dataWorkbook As Workbook
Set dataWorkbook = Workbooks.Open(folderPath & "data_file.xls", ReadOnly:=True)
' Not sure if it is the only sheet in the workbook or not.
' If possible, refer to sheet by sheet name.
Set GetDataWorksheet = dataWorkbook.Worksheets(1)
End Function
Private Function GetAdviserCountsWorksheet() As Worksheet
Dim targetBook As Workbook
' This will raise an error (if book is not already open) so maybe
' provide a full path instead.
Set targetBook = Application.Workbooks("adviser counts (1 & 2).xls")
Set GetAdviserCountsWorksheet = targetBook.Worksheets("Sheet3")
End Function
Private Function GetAdviserRangeInPivotTable(ByVal adviserCountsSheet As Worksheet, ByVal Dept As String)
' There are probably better ways of doing this (e.g. interacting with the
' PivotTable's properties/methods -- rather than just iterating over a range)
Dim lastRow As Long
lastRow = GetLastRow(adviserCountSheet)
With adviserCountsSheet
Dim targetRange As Range
Set targetRange = .Range("A3", .Cells(lastRow, "A"))
Dim startRowIndex As Variant
startRowIndex = Application.Match(Dept, targetRange, 0)
Dim endRowIndex As Variant
endRowIndex = Application.Match(Dept & " Total", targetRange, 0)
Debug.Assert IsNumeric(startRowIndex)
Debug.Assert IsNumeric(endRowIndex)
Debug.Assert endRowIndex > startRowIndex
Set GetAdviserRangeInPivotTable = .Rows(startRowIndex & ":" & endRowIndex)
End With
End Function
Private Sub ReorderSheets(ByVal targetWorkbook As Workbook)
' Moves "ALL" to first, "Count" to second. Does not check if
' sheets exist. Will raise an error (if they do not).
Dim allSheet As Worksheet
Set allSheet = targetWorkbook.Worksheets("ALL")
Dim countSheet As Worksheet
Set countSheet = targetWorkbook.Worksheets("Count")
allSheet.Move Before:=targetWorkbook.Worksheets(1)
countSheet.Move After:=allSheet
End Sub
Private Sub FinaliseAndSaveWorkbook(ByVal targetWorkbook As Workbook, ByVal Dept As String)
ReorderSheets targetWorkbook
Dim outputFilePath As String
outputFilePath = ThisWorkbook.Path & "\" & Dept
' Currently code does not check if parent folder exists
' and whether filename only contains legal characters.
targetWorkbook.SaveAs Filename:=outputFilePath ' Do you want to specify a file format here too?
End Sub
Sub Macro1()
Dim dataSheet As Worksheet
Set dataSheet = GetDataWorksheet()
Dim adviserCountsSheet As Worksheet
Set adviserCountsSheet = GetAdviserCountsWorksheet()
Dim created As Integer
created = 1
Dim Dept As Range
For Each Dept In dataSheet.Columns(1).Cells
If (Dept.Text = "") Then Exit For
' Might be possible to restructure such that you no longer
' need the "created" variable.
If (created = 1) Then
Dim newWorkbook As Workbook ' Needs a better name
Set newWorkbook = Application.Workbooks.Add
End If
Dim cellsToCopy As Range
Set cellsToCopy = GetRowsMatchingDept(ThisWorkbook.Worksheets("Sheet1"), Dept.Text)
Debug.Assert Not (cellsToCopy Is Nothing)
created = 0
If cellsToCopy.Columns(1).Cells.CountLarge < 4000 Then
Dim allSheet As Worksheet
Set allSheet = CreateAllSheet(newWorkbook)
CopyDataToSheetAndFormat cellsToCopy, allSheet.Range("A1")
Dim Adviser As Range
For Each Adviser In dataSheet.Columns(2).Cells
If (Adviser.Text = "") Then Exit For
Set cellsToCopy = GetRowsMatchingAdviser(ThisWorkbook.Worksheets("Sheet1"), Adviser.Text)
If cellsToCopy.Columns(1).Cells.CountLarge < 1500 Then
Dim adviserSheet As Worksheet
Set adviserSheet = CreateAdviserSheet(newWorkbook, Adviser.Text)
CopyDataToSheetAndFormat cellsToCopy, adviserSheet.Range("A1")
AddBordersToAdviserSheet adviserSheet
Set adviserSheet = Nothing
End If
Next Adviser
' This sub will add the sheet Count to each workbook it will simply copy paste from
' the pivot table of the adviser distribution
Dim countSheet As Worksheet
Set countSheet = CreateCountSheet(newWorkbook)
adviserCountsSheet.Rows("1:2").Copy countSheet.Range("A1")
Set cellsToCopy = GetAdviserRangeInPivotTable(adviserCountsSheet, Dept:=Dept.Text)
cellsToCopy.Copy countSheet.Range("A3")
FinaliseAndSaveWorkbook newWorkbook, Dept:=Dept.Text
newWorkbook.Close
created = 1
End If
Next Dept
dataSheet.Parent.Close
End Sub
Основной вывод здесь должен быть как можно более явным (при обращении к workbooks, worksheets, ranges, cells,и т. д.) - и не полагайтесь и не предполагайте, что нужный объект будет активным.