tabbladen kopiëren en samenvoegen uit Excel bestand met macro

[erwin87]

Beste,

Ik ben op zoek naar een macro voor het volgende.

Ik heb het excel bestand totaal.
Nu zou ik graag uit het bestand ‘copy from’
tabbladen fsc, fpb – pe, fpb – bib overhalen samenvoegen en sorteren op startdate (kolom E) in het Excel bestand Totaal.
Deze actie moet meerdere keren per dag gebeuren vandaar dat ik het graag mbv een macro wil.


Ik heb al zitten zoeken en heb volgende gevonden.

Private Sub CommandButton1_Click()
Dim lRij As Long
b = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If Not b = False Then
    Workbooks.Open b
    With Workbooks(Workbooks.Count).Worksheets(1)
        lRij = .Range("A" & Rows.Count).End(xlUp).Row
        Workbooks(Workbooks.Count).Worksheets(1).Range("A3:O" & lRij).Copy ThisWorkbook.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        Workbooks(Workbooks.Count).Close
    End With
End If
Worksheets(1).Range("A3:O" & Range("A" & Rows.Count).End(xlUp).Row).Sort key1:=Range("E2")
End Sub

deze werkt wel maar deze macro neemt enkel de eerste sheet over.
hoe kan ik aangeven welke sheets ik wil kopieren en samenvoegen?
hopelijk kan iemand mij hier verder mee helpen want mijn kennis laat te wensen over.

Alvast bedankt.

 

[HSV]

Om te beginnen zul je daar een lusje voor moeten gebruiken.

Private Sub CommandButton1_Click()
Dim a, j as long
b = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If Not b = False Then
    Workbooks.Open b
    With activeworkbook
      a = array("fsc","fpb – pe","fpb – bib")
       for j = 0 to 2
          .sheets(a(j)).Range("A3:O" & sheets(a(j)).Range("A" & Rows.Count).End(xlUp).Row).Copy ThisWorkbook.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
       next j
     .Close
    End With
End If
sheets(1).Range("A3:O" & sheets(1).Range("A" & Rows.Count).End(xlUp).Row).Sort key1:=Range("E2")
End Sub

 

[erwin87]

Hoi HSV,

de macro stopt na het eerste Tabblad.
ik heb even de 2 bestanden bijgevoegd in bijlage.

Misschien ook even erbij vermelden dat ik enkel de waarde wil plakken.

Alvast bedankt voor de Hulp.

 

[HSV]

tabbladen fsc, fpb – pe, fpb – bib overhalen

In bovenstaand stukje staan twee keer een streepje teveel.

Veranderen in:

a = array("fsc","fpb - pe","fpb - bib")

 

[erwin87]

Hoi HSV dat werkt perfect.

zou het ook mogelijk zijn om enkel de waarde te plakken en niet de opmaak?

 

[HSV]

Het simpelst.
for j = 0 to 2

.sheets(a(j)).Range("A3:O" & sheets(a(j)).Range("A" & Rows.Count).End(xlUp).Row).Copy
 ThisWorkbook.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).pastespecial xlpastevalues
next j

 

[erwin87]

Werkt perfect. Bedankt voor de hulp