Michał Figurski

Wypowiedzi

• Wszystko
• Tylko fora

• 
  Wpis na grupie Fani Excela w temacie Zestawienie wielu arkuszy w jeden - Makro, pętla

  27.05.2015, 10:07

  Witam,
  
  mam problem z utworzeniem makra które pozwoliłoby mi stworzyć zestawienie wielu arkuszy w jednym podsumowywującym.
  - Każdy z arkuszy wyglądałby pod względem strukturalnym tak samo
  - Różniłaby się ilość pozycji i oczywiście ich nazwy
  
  W załączniku plik excel z moją dotychczasową pracą, starałem się stworzyć makro z rejestru dla pierwszej pozycji z pierwszego arkusza po czym jakoś zapętlić zakres zaznaczenia by wykonywało operacje tyle razy ile jest pozycji, niestety po wielu próbach nie udało się.
  - Dokładniejsze opisy o co mi chodzi dokładniej są zawarte w kodzie makra w załączniku
  
  Pozdrawiam i z góry dziękuję
  
  Link do pliku Excel: http://przeklej.org/file/8QVgfb/Nowy.Arkusz.programu.M...
  
  gdyby makro nie było widoczne w pliku:
  
  Sub Import()
  '
  ' Import Makro
  '
  
  'Wkjejenie nagłówka tabeli
  
  Sheets("Protokół 1").Select
  Range("A1:E1").Select
  Selection.Copy
  Sheets("Zestawienie").Select
  Range("A2").Select
  ActiveSheet.Paste
  Application.CutCopyMode = False
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlBottom
  .WrapText = False
  .Orientation = 0
  .AddIndent = False
  .IndentLevel = 0
  .ShrinkToFit = False
  .ReadingOrder = xlContext
  .MergeCells = False
  End With
  With Selection
  .HorizontalAlignment = xlCenter
  .VerticalAlignment = xlCenter
  .WrapText = False
  .Orientation = 0
  .AddIndent = False
  .IndentLevel = 0
  .ShrinkToFit = False
  .ReadingOrder = xlContext
  .MergeCells = False
  End With
  
  'Zaznaczenie pierwszego wiersza tabeli oraz jego wklejenie w arkuszu Zestawienie oraz stworzenie ramki
  
  'Chodzi o zapętlenie tego kodu by powtarzał się dopóki będą dane w protokole,
  'gdyż czasami jest np. 100 pozycji a w kolejnym protokole np 20
  'Chodzi również o zapętlenie tej czynności dla kolejnych protokołów - będą się nazywały tak jak we wzorze
  'może być ich dużo, więc również jakaś pętla
  
  'Idealnie by było gdyby wyrzucało jeszczę nazwę arkusza z którego pobrane zostały dane, tak jak to widać w
  'arkuszu Zestawnienie koniec
  
  'Poniższy kod jest tylko dla zaznaczonego obszaru oraz dla Protokół 1
  
  Range("A3").Select
  Sheets("Protokół 1").Select
  Range("A2:E2").Select
  Selection.Copy
  Sheets("Zestawienie").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  Application.CutCopyMode = False
  Selection.Borders(xlDiagonalDown).LineStyle = xlNone
  Selection.Borders(xlDiagonalUp).LineStyle = xlNone
  With Selection.Borders(xlEdgeLeft)
  .LineStyle = xlContinuous
  .ColorIndex = 0
  .TintAndShade = 0
  .Weight = xlThin
  End With
  With Selection.Borders(xlEdgeTop)
  .LineStyle = xlContinuous
  .ColorIndex = 0
  .TintAndShade = 0
  .Weight = xlThin
  End With
  With Selection.Borders(xlEdgeBottom)
  .LineStyle = xlContinuous
  .ColorIndex = 0
  .TintAndShade = 0
  .Weight = xlThin
  End With
  With Selection.Borders(xlEdgeRight)
  .LineStyle = xlContinuous
  .ColorIndex = 0
  .TintAndShade = 0
  .Weight = xlThin
  End With
  With Selection.Borders(xlInsideVertical)
  .LineStyle = xlContinuous
  .ColorIndex = 0
  .TintAndShade = 0
  .Weight = xlThin
  End With
  With Selection.Borders(xlInsideHorizontal)
  .LineStyle = xlContinuous
  .ColorIndex = 0
  .TintAndShade = 0
  .Weight = xlThin
  End With
  End Sub