Это должно помочь вам начать.Мне было сложно тестировать мой код, но я надеюсь, что ошибок не слишком много.Я включил комментарии, объясняющие цель каждого раздела, но я не знаю, достаточно ли вы знаете VBA, чтобы понять, как я достигаю этой цели.
Мне нужно, чтобы вы переместили (или скопировали) все рабочие книги, из каких данныхдолжен быть извлечен (исходные книги) в ту же папку.Мой первый макрос будет работать лучше, если эта папка содержит только исходные рабочие книги и рабочую книгу, которую я попрошу вас создать.
В этой папке мне нужно, чтобы вы создали новую рабочую книгу с именем что-то вроде «Consolidate.xls»,(Я использую Excel 2003, у вас может быть другое расширение.)
Откройте Consolidate.xls, затем откройте редактор VB.(Я предполагаю базовые знания макросов Excel. При необходимости вам придется подождать, пока я встану. Вы на шесть часов впереди меня, а я на пенсии, поэтому я не встаю на рассвет.)
Создайте модуль и скопируйте в него код ниже.
Запустить макрос FillSourceSheets.Это создаст рабочий лист «SourceSheets» и заполнит его именами рабочих книг и рабочих листов.В моей системе это выглядело так:
| A | B | C | D | E |
|Status|Source workbook |Source worksheets --> |
| |Consolidate.txt |Consolidate| | |
| |Test Parse data 1.xls|Sheet1 |Sheet2|Sheet3|
| |Test Parse data 2.xls|Sheet1 |Sheet4|Sheet2|Sheet3|
Пока не беспокойтесь о столбце «Состояние».
Имена в «Исходной книге» - это файлы, которые может открыть Excel.Обратите внимание, что он может открыть текстовый файл.«Test Parse data 1.xls» и «Test Parse data 2.xls» - мои рабочие тетради.Рабочие таблицы в каждом файле перечислены в найденной последовательности.
Вам необходимо удалить все строки для файлов, которые не являются исходными файлами.Мне пришлось удалить строку для «Consolidate.txt».Вам необходимо удалить имя любого листа, который не содержит исходных данных.В моем случае «Sheet4» из «Test Parse data 2.xls» не содержит исходных данных, и мне пришлось их удалить.В них не должно быть никаких пробелов.Строка, в столбце B которой ничего нет, завершает список.Ячейка, в которой ничего нет, заканчивается рядом.Поэтому после редактирования моего листа это выглядело следующим образом:
| A | B | C | D | E |
|Status|Source workbook |Source worksheets --> |
| |Test Parse data 1.xls|Sheet1 |Sheet2|Sheet3|
| |Test Parse data 2.xls|Sheet1 |Sheet2|Sheet3|
Этот список определяет другие макросы.Он сообщает им, какие книги и листы нужно посмотреть.
Другой макрос, который я включил, - ValidateSheets
У вас есть 20 книг, из которых одна содержит 15 листов.Будет удивительно, если ни одна из них не содержит ошибок, и будет удивительно, если некоторые не будут соответствовать формату, который вы мне дали.ValidateSheets выполняет проверку первого уровня, потому что нет цели делать больше, пока мы точно не знаем, что у нас есть.
ValidateSheets работает со списком рабочих книг и рабочих таблиц в «SourceSheets».Он создает текстовый файл «Process Report.txt», в котором отображается его ход.Если он находит ошибку в «SourceSheets», он немедленно останавливается с сообщением на экране.В «SourceSheets» не должно быть никаких ошибок, но если они есть, вам придется их исправить, перезапустите макрос.Если он находит ошибку в листе, он выводит сообщение об ошибке в «Process Report.txt» и переходит к следующему листу.
Попробуйте запустить ValidateSheets и посмотрите, как вы продвигаетесь.
Option Explicit
Sub FillSourceSheets()
Dim ColCrnt As Long
Dim ErrMsg As String
Dim Filename As String
Dim InxWSheet As Long
Dim PathCrnt As String
Dim RowCrnt As Long
Dim WBookOther As Workbook
Dim WBookThis As Workbook
If Workbooks.Count > 1 Then
' It is easy to get into a muddle if there are multiple workbooks
' open at the start of a macro like this. Avoid the problem.
Call MsgBox("Please close all other workbooks", vbOKOnly)
Exit Sub
End If
' Record this workbook so we do not confuse it with any we open
Set WBookThis = ActiveWorkbook
' Record the folder containing the current workbook
PathCrnt = ActiveWorkbook.Path
' Create a new worksheet, name it SourceSheets and fill the heading row
Sheets.Add
With ActiveSheet
.Name = "SourceSheets"
.Range("A1").Value = "Status"
.Range("B1").Value = "Source workbook"
.Range("C1").Value = "Source worksheets -->"
.Range("C1:E1").MergeCells = True
.Range("A1:C1").Font.Bold = True
End With
RowCrnt = 2
Filename = Dir$(PathCrnt & "\*.*")
' Loop for every file in the activeworkbook's folder
Do While Filename <> ""
If Filename <> ActiveWorkbook.Name Then
' This file is not the active workbook
' so try to open it as a workbook.
Err.Clear
ErrMsg = ""
On Error Resume Next
Set WBookOther = Workbooks.Open(PathCrnt & "\" & Filename)
If Err.Number <> 0 Then
' On Error GoTo 0 clears Err.Num and Err.Description so save
ErrMsg = Err.Number & " " & Err.Description
End If
On Error GoTo 0
If ErrMsg <> "" Then
' This file cannot be opened by Excel
Debug.Print Filename & " " & ErrMsg
Else
' This file has been successfully opened. Create a row for it.
' Start by placing the file name in column 2.
WBookThis.Sheets("SourceSheets").Cells(RowCrnt, 2).Value = Filename
ColCrnt = 3
' Place each sheet name in a cell starting from column 3
For InxWSheet = 1 To WBookOther.Worksheets.Count
WBookThis.Sheets("SourceSheets").Cells(RowCrnt, ColCrnt).Value = _
WBookOther.Worksheets(InxWSheet).Name
ColCrnt = ColCrnt + 1
Next
WBookOther.Close SaveChanges:=False
RowCrnt = RowCrnt + 1
End If
End If
Filename = Dir$ ' Get next file name
Loop
With WBookThis.Sheets("SourceSheets")
.Columns.AutoFit
End With
End Sub
Sub ValidateSheets()
Dim CellValue As String
Dim ColSrcList As Long
Dim ColSrcSheetCrnt As Long
Dim ColSrcSheetLast As Long
Dim Found As Boolean
Dim InxWSheetCrnt As Long
Dim OutputFileNum As Integer
Dim PathCrnt As String
Dim Rng As Range
Dim RowSrcList As Long
Dim RowSrcSheetBlockStart As Long
Dim RowSrcSheetCrnt As Long
Dim RowSrcSheetFinal As Long
Dim WBookOtherNameCrnt As String
Dim WSheetOtherNameCrnt As String
Dim WBookOther As Workbook
Dim WBookThis As Workbook
If Workbooks.Count > 1 Then
' It is easy to get into a muddle if there are multiple workbooks
' open at the start of a macro like this. Avoid the problem.
Call MsgBox("Please close all other workbooks", vbOKOnly)
Exit Sub
End If
' Record this workbook so we do not confuse it with any we open
Set WBookThis = ActiveWorkbook
' Record the folder containing the current workbook
PathCrnt = ActiveWorkbook.Path
' Open text file to which progress messages will be written
OutputFileNum = FreeFile
Open PathCrnt & "\Process Report.txt" For Output Lock Write As #OutputFileNum
With WBookThis.Sheets("SourceSheets")
' Load name of first workbook and first worksheet
RowSrcList = 2 ' Row of first workbook
ColSrcList = 3 ' Column of first worksheet
WBookOtherNameCrnt = .Cells(RowSrcList, 2).Value
WSheetOtherNameCrnt = .Cells(RowSrcList, ColSrcList).Value
End With
' This loop repeats for each worksheet listed in worksheet SourceSheets
Do While True
' WBookOtherNameCrnt and WSheetOtherNameCrnt have been loaded either
' before this loop or by the code at the end
If Not WBookOther Is Nothing Then
' There is an open workbook. Check it is the one
' required for this loop.
If LCase(WBookOtherNameCrnt) <> LCase(WBookOther.Name) Then
' This is not the same workbook.
' Close the open workbook and clear reference to it
WBookOther.Close SaveChanges:=False
Set WBookOther = Nothing
End If
End If
If WBookOther Is Nothing Then
' The workbook to be tested is not open so we need to
' open it. First check it exists
If Dir$(PathCrnt & "\" & WBookOtherNameCrnt) <> "" Then
' The specified file exists but it may not be a valid workbook.
' Use Excel's error handling
Err.Clear
On Error Resume Next
Set WBookOther = Workbooks.Open(PathCrnt & "\" & WBookOtherNameCrnt)
On Error GoTo 0
If Err.Number <> 0 Then
Call MsgBox("Open of """ & WBookOtherNameCrnt & """ failed. " & _
"Error: " & Err.Number & " " & Err.Description, vbOKOnly)
Set WBookOther = Nothing
Close OutputFileNum ' Close text file
Exit Sub
End If
Else
Call MsgBox("I could not find workbook """ & WBookOtherNameCrnt _
& """", vbOKOnly)
Close OutputFileNum ' Close text file
Exit Sub
End If
End If
' The required workbook is open.
With WBookOther
' Check the worksheet exists
Found = False
For InxWSheetCrnt = 1 To .Worksheets.Count
If .Worksheets(InxWSheetCrnt).Name = WSheetOtherNameCrnt Then
Found = True
Exit For
End If
Next
If Not Found Then
' The workbook was not found
Call MsgBox("I could not find worksheet """ & WSheetOtherNameCrnt _
& """ with workbook """ & WBookOtherNameCrnt & """", vbOKOnly)
.Close
Close OutputFileNum ' Close text file
Exit Sub
End If
Print #OutputFileNum, "Process sheet """ & WSheetOtherNameCrnt & _
""" of workbook """ & WBookOther.Name & """"
With Sheets(WSheetOtherNameCrnt)
' Validate source sheet matches expected format
' Rows 1 to 3 are ignored.
' Find final row of sheet
Set Rng = .Cells.Find("*", .Range("A1"), _
xlFormulas, , xlByRows, xlPrevious)
If Rng Is Nothing Then
' The sheet is empty
Print #OutputFileNum, " Sheet is empty"
Exit Do
End If
RowSrcSheetFinal = Rng.Row
' There are one of more blocks. The first block starts in Row 4
RowSrcSheetBlockStart = 4
Do While True ' Loop for each block
' Row 1 of a block must consider of one or more three cell merged
' areas. Each merged area contains a string with value of format:
' "N" number "/" number.
' Search backwards from the column 1 of the next row
' for a cell with a value
Set Rng = .Cells.Find("*", .Cells(RowSrcSheetBlockStart + 1, 1), _
xlFormulas, , xlByRows, xlPrevious)
If Rng Is Nothing Then
' This should not be possible because have
' already check for empty sheet
Print #OutputFileNum, " Sheet is empty"
Exit Do
End If
If Rng.Row <> RowSrcSheetBlockStart Then
Print #OutputFileNum, " I was expecting a value on row " & _
RowSrcSheetBlockStart
Exit Do
End If
ColSrcSheetLast = Rng.Column
For ColSrcSheetCrnt = 1 To ColSrcSheetLast Step 3
' Check the three cells are merged
If .Range(.Cells(RowSrcSheetBlockStart, ColSrcSheetCrnt), _
.Cells(RowSrcSheetBlockStart, ColSrcSheetCrnt + 2)).MergeCells _
= True Then
If Not .Cells(RowSrcSheetBlockStart, ColSrcSheetCrnt).Value Like "N*/*" Then
' Cell does not contain "N" number "/" number
Print #OutputFileNum, " Row " & RowSrcSheetBlockStart & _
" is the start of a block. I was expecting " & _
"columns " & ColNumToCode(ColSrcSheetCrnt) & " to " & _
ColNumToCode(ColSrcSheetCrnt + 2) & " to contain a value with " & _
"the format ""N"" number ""/"" number"
Exit Do
End If
Else
' Three cells are not merged
Print #OutputFileNum, " Row " & RowSrcSheetBlockStart & _
" is the start of a block. I was expecting " & _
"columns " & ColNumToCode(ColSrcSheetCrnt) & " to " & _
ColNumToCode(ColSrcSheetCrnt + 2) & " to be merged"
Exit Do
End If
Next
' Cells with Rows 2 to 4 of a block must contain
' surnames or be empty.
' Check they do not contain flat numbers
For RowSrcSheetCrnt = RowSrcSheetBlockStart + 1 To _
RowSrcSheetBlockStart + 3
For ColSrcSheetCrnt = 1 To ColSrcSheetLast + 2
CellValue = .Cells(RowSrcSheetCrnt, ColSrcSheetCrnt).Value
If CellValue = "" Or Not LCase(CellValue Like "#####[a-z]") Then
' Cell valid
Else
' Cell contains a flat number. Cannot be a surname.
Print #OutputFileNum, " Row " & RowSrcSheetCrnt & _
" should only contain surnames but column " & _
ColNumToCode(ColSrcSheetCrnt) & " contains a flat number"
Exit Do
End If
Next
Next
' Rows 5 of a block to the next blank row should contain
' nothing but flat numbers.
RowSrcSheetCrnt = RowSrcSheetBlockStart + 5
Do While True ' Loop until find a blank row
Found = False ' Nothing found on this row
For ColSrcSheetCrnt = 1 To ColSrcSheetLast + 2
CellValue = .Cells(RowSrcSheetCrnt, ColSrcSheetCrnt).Value
If CellValue <> "" Then
Found = True ' Value found on this row
If LCase(CellValue Like "#####[a-z]") Then
' Cell valid
Else
' Cell does not contain a flat number
Print #OutputFileNum, " Row " & RowSrcSheetCrnt & _
" should only contain flat numbers but column " & _
ColNumToCode(ColSrcSheetCrnt) & " contains " & CellValue
Exit Do
End If
End If
Next
If Not Found Then
' This is a blank line
Exit Do
End If
RowSrcSheetCrnt = RowSrcSheetCrnt + 1
Loop
' This block is finished.
Print #OutputFileNum, " No error found in block starting " & _
"on row " & RowSrcSheetBlockStart
' Is there another block?
If RowSrcSheetCrnt > RowSrcSheetFinal Then
' No more blocks
Exit Do
Else
' Find the next row with a value which should be the first
' row of the next block.
Set Rng = .Cells.Find("*", .Cells(RowSrcSheetCrnt, 1), _
xlFormulas, , xlByRows, xlNext)
If Rng Is Nothing Then
' This should not be possible since
' have already found a value on a later row
Print #OutputFileNum, " I expected another block under row " _
& RowSrcSheetCrnt & " but I could not find it."
Exit Do
End If
RowSrcSheetBlockStart = Rng.Row
End If
Loop
End With
End With
' Load details of next worksheet
With WBookThis.Sheets("SourceSheets")
ColSrcList = ColSrcList + 1
' Load name of next worksheet
WSheetOtherNameCrnt = .Cells(RowSrcList, ColSrcList).Value
If WSheetOtherNameCrnt = "" Then
' There are no more worksheets on this row
RowSrcList = RowSrcList + 1
WBookOtherNameCrnt = .Cells(RowSrcList, 2).Value
If WBookOtherNameCrnt = "" Then
' End of list reached.
Exit Do
End If
ColSrcList = 3
WSheetOtherNameCrnt = .Cells(RowSrcList, ColSrcList).Value
If WSheetOtherNameCrnt = "" Then
Call MsgBox("Row " & RowSrcList & " of SourceSheets has a " & _
"workbook name but no worksheet name.", vbOKOnly)
Close OutputFileNum ' Close text file
Exit Sub
End If
End If
End With
Loop
If Not WBookOther Is Nothing Then
WBookOther.Close SaveChanges:=False
Set WBookOther = Nothing
End If
Close OutputFileNum ' Close text file
End Sub
Function ColCodeToNum(ColStg As String) As Long
Dim lcColStg As String
lcColStg = LCase(ColStg)
ColCodeToNum = IIf(Len(ColStg) > 1, (Asc(Left(ColStg, 1)) - 64) * 26, 0) + _
Asc(Right(ColStg, 1)) - 64
End Function
Function ColNumToCode(ColNum As Long) As String
ColNumToCode = IIf(ColNum > 26, Chr(64 + ((ColNum - 1) \ 26)), "") & _
Chr(65 + ((ColNum - 1) Mod 26))
End Function