Source Code for Me (s-c.me)

Allows you to paste souce code to blogs! Adapted for Twitter! Here is Search Form in case you missed your code.
Tags: VisualBasic, Created At: 10/24/2016 8:00:28 PMViews:

HTML view:
Copy Source | Copy HTML
  1. Sub Consolidated_Range_of_Books_and_Sheets()
  2. Dim iBeginRange As Object, lCalc As Long
  3. Dim sRngAddress As String, oAwb As String, sCopyAddress As String, sSheetName As String
  4. Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
  5. Dim wsSh As Object, wsDataSheet As Object, bPolyBooks As Boolean, avFiles
  6. On Error Resume Next
  7. Set iBeginRange = Application.Range("a2:c6")
  8. If iBeginRange Is Nothing Then Exit Sub
  9. sSheetName = "цех"
  10. On Error GoTo 0
  11. If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then
  12. avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
  13. If VarType(avFiles) = vbBoolean Then Exit Sub
  14. bPolyBooks = True
  15. Else
  16. avFiles = Array(ThisWorkbook.FullName)
  17. End If
  18. With Application
  19. lCalc = .Calculation
  20. .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
  21. End With
  22. ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
  23. Set wsDataSheet = ThisWorkbook.ActiveSheet
  24. For li = LBound(avFiles) To UBound(avFiles)
  25. If bPolyBooks Then Workbooks.Open Filename:=avFiles(li)
  26. oAwb = Dir(avFiles(li), vbDirectory)
  27. For Each wsSh In Workbooks(oAwb).Sheets
  28. If wsSh.Name Like sSheetName Then
  29. If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
  30. With wsSh
  31. Select Case iBeginRange.Count
  32. Case 1
  33. lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
  34. iLastColumn = .Cells.SpecialCells(xlLastCell).Column
  35. sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address
  36. Case Else
  37. sCopyAddress = iBeginRange.Address
  38. lLastrow = iBeginRange.Rows.Count
  39. iLastColumn = iBeginRange.Columns.Count
  40. End Select
  41. lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
  42. sRngAddress = .Range(.Cells(lLastRowMyBook, 1), .Cells(lLastRowMyBook + lLastrow, iLastColumn)).Address
  43. .Range(sCopyAddress).Copy wsDataSheet.Range(sRngAddress)
  44. End With
  45. End If
  46. NEXT_:
  47. Next wsSh
  48. If bPolyBooks Then Workbooks(oAwb).Close False
  49. Next li
  50. With Application
  51. .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
  52. End With
  53. End Sub

Based on Manoli.Net's CodeFormatter. Made by Topbot (c) 2008-2017