Cellen uit verschillende werkbladen samenvoegen VBA

[everse]

Hallo allemaal,

In een oud (2009) topic heb ik onderstaand stukje VBA gevonden. Hiermee kan ik gegevens uit Sheet1 van alle werkbladen in de betreffende folder samenvoegen in één werkmap.

Ik dacht dit te kunnen doen door .UsedRange te vervangen voor .Range("A14") AND .range("A16"). Dit werkt echter niet fout: 'deze eigenschap of methode wordt niet ondersteunt door dit object'

Kan iemand mij helpen met het modificeren van onderstaande code zodat alleen cellen A14 en A16 worden toegevoegd? Deze mogen naast elkaar worden geplaatst. Dus in rijen A en B.

Sub samenvoeg()
Application.ScreenUpdating = False
  For Each fl In CreateObject("scripting.filesystemobject").getfolder("C:\Users\everse\test").Files
   
       With Workbooks.Add(fl)
          sq = .Sheets("Sheet1").UsedRange
          .Close False
       End With
       ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sq), UBound(sq, 2)) = sq
  
  Next
  Application.ScreenUpdating = True
End Sub

Alvast enorm bedankt!

 

[MDN111]

Dag everse !

Probeer deze code eens:

Sub samenvoeg()
Dim fl, sq, myArray
Application.ScreenUpdating = False

  For Each fl In CreateObject("scripting.filesystemobject").getfolder("C:\Users\everse\test").Files
   
       With Workbooks.Add(fl)
       
           With Sheets("Sheet1")
           
              Set sq = .Range("A14")
              Set sq = sq.Resize(, 2)
              sq.Cells(1, 2) = .Range("A16")
              myArray = sq
           
           End With
           
          .Close False
       End With
  
       ThisWorkbook.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Resize(, 2) = myArray
  
  Next
  Application.ScreenUpdating = True

End Sub

Grtz,
MDN111.

 

[everse]

Hoi MDN111,

bedankt voor je suggestie. Ik krijg nu de melding "Het subscript valt buiten het bereik". Het werkt dus nog niet.

Grt,
everse

 

[HSV]

Test het zo maar eens.

Sub samenvoeg()
Dim sq(1), fl As Object
Application.ScreenUpdating = False
  For Each fl In CreateObject("scripting.filesystemobject").getfolder("C:\Users\everse\test").Files
      With Workbooks.Add(fl)
            With .Sheets(1)
               sq(0) = .Range("a14")
               sq(1) = .Range("a16")
               ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 2) = sq
            End With
        .Close False
       End With
     Next
  Application.ScreenUpdating = True
End Sub

 

[MDN111]

@everse:

Het verbaast mij dat die code niet werkt. Vooraleer ze te posten heb ik dat getest en bij mij werkte het zonder probleem. Zou het kunnen dat er bij de Excel-bestanden, waaruit je de gegevens haalt, één bij zit die geen sheet heeft met de naam "Sheet1" ?

@HSV:

Er zijn zo van die momenten dat je jezelf wel tegen het hoofd kan slaan om iets voor de hand liggend niet te hebben opgemerkt. Zulk moment had ik toen ik je code zag. Jouw code vind ik uiteraard beter wegens korter en ook eleganter. Ik wist niet dat je een range zomaar kon toewijzen aan een array tot ik dat las in die topic uit 2009 en waarschijnlijk was ik daar zo van onder de indruk dat ik persé eerst een geldige range wilde vormen om ze dan in z'n geheel toe te wijzen aan een array, waarvoor ik zelfs een extra variabele in het leven heb geroepen. 'k Ben daar dus niet erg fier op.

Grtz,
MDN111.

 

[everse]

@MDN111 Het ligt ongetwijfeld aan mezelf hoor. Ik ga nog even storing zoeken. Iig hartelijk dank voor je hulp!

@HVS Dank ook voor jouw suggestie!

 

[snb]

Sub M_snb()
  For Each fl In CreateObject("scripting.filesystemobject").getfolder("C:\Users\everse\test").Files
     With getobject(fl)
       ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(,2) = array(.sheets(1).cells(14,1),.sheets(1).cells(16,1))
       .Close False
     End With
  Next
End Sub

 

[MDN111]

De enig mogelijke commentaar op deze code is een quote van Antoine de Saint-Exupery:

"It seems that perfection is attained not when there is nothing more to add, but when there is nothing more to remove".

:thumb:

Grtz,
MDN111.

 

[snb]

@MDN111

Die kende ik nog niet (mirabile dictu ! ).

Ik word nieuwsgierig naar de Franse versie...

Trouvé

Il semble que la perfection soit atteinte non quand il n'y a plus rien à ajouter, mais quand il n'y a plus rien à retrancher.

 

[MDN111]

@snb

Het wordt nog leuker als je weet in welke context ik met die quote heb kennis gemaakt. Die komt namelijk uit deze video.

 

[everse]

@SNB @MDN111

Hartelijk dank voor jullie reacties. Het werkt perfect. Ook mooi om te zien hoe jullie de code verder optimaliseren. Ik probeer er wat van te leren
Nu heb ik had nog een laatste vraag maar die heb ik zelf al opgelost door goed te kijken wat jullie doen. Super! :thumb: