1

Topic: Allocation of the data from files on pages in the new book

It is necessary that the code worked as follows:
1. You select files
2. At sight No1 the information is copied
3. There is a new document
4. The copied information is interposed on a single sheet with file name.
5. It is saved as +
Now this code works as follows:
1. You select files
2. At sight No1 the information is copied
3. There is a new document
4. The copied information is interposed on "sheet 4" the friend under
5. It is saved as +
Point 4

Option Explicit
Sub Consolidated_Range_of_Books_and_Sheets ()
Dim iBeginRange As Object, lCalc As Long, lCol As Long
Dim oAwb As String, sCopyAddress As String, sSheetName As String
Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
Dim wsSh As Object, wsDataSheet As Object, bPolyBooks As Boolean, avFiles
Dim wbAct As Workbook
Dim bPasteValues As Boolean
On Error Resume Next
' we Select a range of sampling from books
Set iBeginRange = Range ("A10:Z20") ' the range is underlined necessary
If iBeginRange Is Nothing Then Exit Sub
' we fill out a sheet name
sSheetName = "List1"
On Error GoTo 0
' to Interpose values of cells (without formulas and formats)
bPasteValues = vbYes
' C the data from books
avFiles = Application. GetOpenFilename ("Excel files (*.xls *),*.xls *", "the Choice of files", True)
If VarType (avFiles) = vbBoolean Then Exit Sub
bPolyBooks = True
lCol = 1
' we disconnect screen update, autorecalculation of formulas and tracing of events
' for speed of performance of the code and for avoidance of errors if in books there are other codes
With Application
lCalc =.Calculation
.ScreenUpdating = False:.EnableEvents = False:.Calculation = xlManual
End With
' ' we create new sheet in the book for collection
Set wsDataSheet = Workbooks. Add. Sheets. Add (After: = Sheets (Sheets. Count))
' a cycle under books
' ' we cause dialogue of a choice of files for import
For li = LBound (avFiles) To UBound (avFiles)
If bPolyBooks Then
Set wbAct = Workbooks. Open (Filename: = avFiles (li))
Else
Set wbAct = ThisWorkbook
End If
oAwb = wbAct. Name
' we create new sheet in the book for collection
wsDataSheet. Name = oAwb
' a cycle on sheets
For Each wsSh In wbAct. Sheets
If wsSh. Name Like sSheetName Then
' If the sheet name coincides with a sheet name in which it is collected the data
' and collection goes only from the active book - that we pass to following sheet
If wsSh. Name = wsDataSheet. Name And bPolyBooks = False Then GoTo NEXT_
With wsSh
Select Case iBeginRange. Count
Case 1 ' it is collected the data since the specified cell and till the end of the data
lLastrow =.Cells (1, 1).SpecialCells (xlLastCell).Row
iLastColumn =.Cells. SpecialCells (xlLastCell).Column
sCopyAddress =.Range (.Cells (iBeginRange. Row, iBeginRange. Column).Cells (lLastrow, iLastColumn)).Address
Case Else ' it is collected the data from the fixed range
sCopyAddress = iBeginRange. Address
End Select
lLastRowMyBook = wsDataSheet. Cells. SpecialCells (xlLastCell).Row + 1
' we interpose a book name from which the data is collected
If lCol Then wsDataSheet. Cells (lLastRowMyBook, 1).Resize (Range (sCopyAddress).Rows. Count).Value = oAwb
If bPasteValues Then ' if it is interposed only values
.Range (sCopyAddress).Copy
wsDataSheet. Cells (lLastRowMyBook, 1).Offset (lCol).PasteSpecial xlPasteValues
Else
.Range (sCopyAddress).Copy wsDataSheet. Cells (lLastRowMyBook, 1).Offset (lCol)
End If
End With
Application. CutCopyMode = False
End If
NEXT_:
Next wsSh
If bPolyBooks Then wbAct. Close False
Next li
With Application
.ScreenUpdating = True:.EnableEvents = True:.Calculation = lCalc
End With
ActiveWorkbook. SaveAs Filename: = "Itog _" AND Date AND "_.xls"
End Sub