Уважаемые форумчане!
Нашел здесь макрос, который замечательно работает. Спасибо за это, как понимаю The_Prist'у.
Sub Consolidated_Range_of_Books_and_Sheets()
Dim iBeginRange As Object, lCalc As Long
Dim sRngAddress As String, 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
On Error Resume Next
Set iBeginRange = Application.InputBox("Âûáåðèòå äèàïàçîí ñáîðà äàííûõ." & vbCrLf & _
"1. Ïðè âûáîðå òîëüêî îäíîé ÿ÷åéêè äàííûå áóäóò ñîáðàíû ñî âñåõ ëèñòîâ íà÷èíàÿ ñ ýòîé ÿ÷åéêè. " & _
vbCrLf & "2. Ïðè âûäåëåíèè íåñêîëüêèõ ÿ÷ååê äàííûå áóäóò ñîáðàíû òîëüêî ñ óêàçàííîãî äèàïàçîíà âñåõ ëèñòîâ.", Type:=8)
If iBeginRange Is Nothing Then Exit Sub
sSheetName = InputBox("Ââåäèòå èìÿ ëèñòà, ñ êîòîðîãî ñîáèðàòü äàííûå(åñëè íå óêàçàí, òî äàííûå ñîáèðàþòñÿ ñî âñåõ ëèñòîâ)", "Ïàðàìåòð")
If sSheetName = "" Then sSheetName = "*"
On Error GoTo 0
If MsgBox("Ñîáðàòü äàííûå ñ íåñêîëüêèõ êíèã?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then
avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Âûáîð ôàéëîâ", , True)
If VarType(avFiles) = vbBoolean Then Exit Sub
bPolyBooks = True
Else
avFiles = Array(ThisWorkbook.FullName)
End If
With Application
lCalc = .Calculation
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
End With
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
Set wsDataSheet = ThisWorkbook.ActiveSheet
For li = LBound(avFiles) To UBound(avFiles)
If bPolyBooks Then Workbooks.Open Filename:=avFiles(li)
oAwb = Dir(avFiles(li), vbDirectory)
For Each wsSh In Workbooks(oAwb).Sheets
If wsSh.Name Like sSheetName Then
If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
With wsSh
Select Case iBeginRange.Count
Case 1
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
sCopyAddress = iBeginRange.Address
lLastrow = iBeginRange.Rows.Count
iLastColumn = iBeginRange.Columns.Count
End Select
lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
sRngAddress = .Range(.Cells(lLastRowMyBook, 1), .Cells(lLastRowMyBook + lLastrow, iLastColumn)).Address
.Range(sCopyAddress).Copy wsDataSheet.Range(sRngAddress)
End With
End If
NEXT_:
Next wsSh
If bPolyBooks Then Workbooks(oAwb).Close False
Next li
With Application
.ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
End With
End Sub
А вопрос такой - что в нем изменить, чтобы переносились только значения, без формул? К сожалению, в исходниках есть ссылки на другие литы (условные), которые, естественно, летят при копировании на один лист в совсем другие строки. Самому досконально разобраться в VBA совсем не хватает времени, к сожалению((
Заранее благодарен.
Нашел здесь макрос, который замечательно работает. Спасибо за это, как понимаю The_Prist'у.
Sub Consolidated_Range_of_Books_and_Sheets()
Dim iBeginRange As Object, lCalc As Long
Dim sRngAddress As String, 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
On Error Resume Next
Set iBeginRange = Application.InputBox("Âûáåðèòå äèàïàçîí ñáîðà äàííûõ." & vbCrLf & _
"1. Ïðè âûáîðå òîëüêî îäíîé ÿ÷åéêè äàííûå áóäóò ñîáðàíû ñî âñåõ ëèñòîâ íà÷èíàÿ ñ ýòîé ÿ÷åéêè. " & _
vbCrLf & "2. Ïðè âûäåëåíèè íåñêîëüêèõ ÿ÷ååê äàííûå áóäóò ñîáðàíû òîëüêî ñ óêàçàííîãî äèàïàçîíà âñåõ ëèñòîâ.", Type:=8)
If iBeginRange Is Nothing Then Exit Sub
sSheetName = InputBox("Ââåäèòå èìÿ ëèñòà, ñ êîòîðîãî ñîáèðàòü äàííûå(åñëè íå óêàçàí, òî äàííûå ñîáèðàþòñÿ ñî âñåõ ëèñòîâ)", "Ïàðàìåòð")
If sSheetName = "" Then sSheetName = "*"
On Error GoTo 0
If MsgBox("Ñîáðàòü äàííûå ñ íåñêîëüêèõ êíèã?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then
avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Âûáîð ôàéëîâ", , True)
If VarType(avFiles) = vbBoolean Then Exit Sub
bPolyBooks = True
Else
avFiles = Array(ThisWorkbook.FullName)
End If
With Application
lCalc = .Calculation
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
End With
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
Set wsDataSheet = ThisWorkbook.ActiveSheet
For li = LBound(avFiles) To UBound(avFiles)
If bPolyBooks Then Workbooks.Open Filename:=avFiles(li)
oAwb = Dir(avFiles(li), vbDirectory)
For Each wsSh In Workbooks(oAwb).Sheets
If wsSh.Name Like sSheetName Then
If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
With wsSh
Select Case iBeginRange.Count
Case 1
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
sCopyAddress = iBeginRange.Address
lLastrow = iBeginRange.Rows.Count
iLastColumn = iBeginRange.Columns.Count
End Select
lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
sRngAddress = .Range(.Cells(lLastRowMyBook, 1), .Cells(lLastRowMyBook + lLastrow, iLastColumn)).Address
.Range(sCopyAddress).Copy wsDataSheet.Range(sRngAddress)
End With
End If
NEXT_:
Next wsSh
If bPolyBooks Then Workbooks(oAwb).Close False
Next li
With Application
.ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
End With
End Sub
А вопрос такой - что в нем изменить, чтобы переносились только значения, без формул? К сожалению, в исходниках есть ссылки на другие литы (условные), которые, естественно, летят при копировании на один лист в совсем другие строки. Самому досконально разобраться в VBA совсем не хватает времени, к сожалению((
Заранее благодарен.