Доброго времени суток! Прошу оказать любезность и помочь в решении следующей задачи.
исходные данные: в папке c:\october находятся несколько десятков однотипных файлов "100.xls " , "104.xls " ,"105.xls " ,"110.xls " , и т.д. задача: из каждого файла скопировать значения ячеек из диапазона А1:D1 в файл c:\month\common.xls, на его первый лист таким образом, чтобы во второй строке были ячейки из файла "100.xls " (то есть с наименьшим номером),в третей "104.xls " и т.д. по возрастанию.
Доброго времени суток! Прошу оказать любезность и помочь в решении следующей задачи.
исходные данные: в папке c:\october находятся несколько десятков однотипных файлов "100.xls " , "104.xls " ,"105.xls " ,"110.xls " , и т.д. задача: из каждого файла скопировать значения ячеек из диапазона А1:D1 в файл c:\month\common.xls, на его первый лист таким образом, чтобы во второй строке были ячейки из файла "100.xls " (то есть с наименьшим номером),в третей "104.xls " и т.д. по возрастанию.Michael
alex77755, огромное спасибо. Вы единственный, кто откликнулся на мои мольбы о помощи. с помощью вашего супер мощного макроса сделал под свои нужды упрощенный вариант:
[vba]
Code
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.Range("a2:c6") If iBeginRange Is Nothing Then Exit Sub 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]
но возникла проблема, о которой, в силу своей отсталости, даже и не подумал сразу. В ячейках, содержащих мои данные, оказались формулы, и в результате у меня копируются нолики(((То есть, мне нужно, чтобы копировались не формулы, а значения. не поскажете, что и где нужно подрисовать?
alex77755, огромное спасибо. Вы единственный, кто откликнулся на мои мольбы о помощи. с помощью вашего супер мощного макроса сделал под свои нужды упрощенный вариант:
[vba]
Code
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.Range("a2:c6") If iBeginRange Is Nothing Then Exit Sub 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]
но возникла проблема, о которой, в силу своей отсталости, даже и не подумал сразу. В ячейках, содержащих мои данные, оказались формулы, и в результате у меня копируются нолики(((То есть, мне нужно, чтобы копировались не формулы, а значения. не поскажете, что и где нужно подрисовать?Michael