Werkbladen uit 1 map samenvoegen met macro

[ScriptGys]

Hartelijk dank voor je snelle reactie.

Ik heb het nu zo gedaan maar ik krijg nog steeds een error op dezelfde regel als voorheen

Sub samenvoegmg()
  Application.ScreenUpdating = False
  For Each fl In CreateObject("scripting.filesystemobject").getfolder("D:\test").Files
     With Workbook.Add(fl)
         .Sheets("Herschikking").UsedRange.Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
         ThisWorkbook.Sheets(1).Columns(12).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
         sq.Columns(1).Replace "soort", "", xlWhole
            sq.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .Close False
     End With
  Next
  Application.ScreenUpdating = True
End Sub

 

[Wigi]

Zet haakjes rond fl en geen spatie ertussen.

Na de lus doorheen de bestanden zet je:

ThisWorkbook.Sheets(1).Columns(12).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

sq.Columns(1).Replace "soort", "", xlWhole
sq.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Wigi

Lees de gegeven instructies goed door, aub.

 

[ScriptGys]

Sorry ik ben niet zo heel bedreven met Macro's. Toch heb ik mijn best gedaan. Is dit wel de goede opzet?

Sub samenvoegmg()
  Application.ScreenUpdating = False
  For Each fl In CreateObject("scripting.filesystemobject").getfolder("D:\test").Files
    With Workbook.Add(fl)
        .Sheets("Herschikking").UsedRange.Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .Close False
    End With
    ThisWorkbook.Sheets(1).Columns(12).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    sq.Columns(1).Replace "soort", "", xlWhole
    sq.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  Next
  Application.ScreenUpdating = True
End Sub

Ik krijg nog steeds een foutmelding (Foutcode 424 tijdens uitvoering: Object vereist) op de volgende regel With Workbook.Add(fl)

 

[Wigi]

Ik krijg nog steeds een foutmelding (Foutcode 424 tijdens uitvoering: Object vereist) op de volgende regel With Workbook.Add(fl)

Dit zou niet gebeuren als u de code gebruikt die anderen al gegeven hebben. Daar luidt het immers With Workbooks.add(fl) i.p.v. With Workbook.add(fl)

Sorry ik ben niet zo heel bedreven met Macro's. Toch heb ik mijn best gedaan. Is dit wel de goede opzet?

Die extra regels komen niet binnen de lus (For... Next) maar erna. Na de Next dus.

 

[Warme bakkertje]

Sub samenvoegmg()
  Application.ScreenUpdating = False
  For Each fl In CreateObject("scripting.filesystemobject").getfolder("D:\Mijn documenten").Files
    With Workbook[COLOR="Red"]s[/COLOR].Add(fl)
        .Sheets("Herschikking").UsedRange.Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .Close False
    End With
    Next
    ThisWorkbook.Sheets(1).Columns(12).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    sq.Columns(1).Replace "soort", "", xlWhole
    sq.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  Application.ScreenUpdating = True
End Sub

Zoals aangegeven NA de lus doorheen de bestanden dus na Next

De Wim was mij juist voor

 

[ScriptGys]

Dat was inderdaad een stomme fout. Shame on me!!!

Het werkt nu bijna goed ik krijg alleen nog een error op de volgende regels

sq.Columns(1).Replace "soort", "", xlWhole
    sq.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Ik dacht slim te zijn door dit als volgt aan te passen

ThisWorkbook.Sheets(1).Columns(1).Replace "Soort", "", xlWhole
    ThisWorkbook.Sheets(1).Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Ik krijg dan geen foutmelding meer maar hij verwijderd ook geen lege regels. Wat o wat doe ik fout.

 

[snb]

Sub samenvoeg()
  Application.ScreenUpdating = False
  For Each fl In CreateObject("scripting.filesystemobject").getfolder("D:\test").Files
     With workbooks.add(fl)
         .Sheets("Herschikking").UsedRange.copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .Close False
     End With
  Next
  With ThisWorkbook.Sheets(1)
     .Columns(12).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
     With .Columns(1)
         .Replace "soort", "",xlwhole
         .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
     End With
  End With
  Application.ScreenUpdating = True
End Sub

 

[ScriptGys]

Helpmijers,

Hartelijk dank voor jullie hulp! Het is gelukt nu. Ik snap de hele opzet van de macro nog niet helemaal maar daar ga ik me zeker in verdiepen!!!!

Nogmaals mijn grote dank!

 

[Warme bakkertje]

Dan mag de vraag terug op opgelost

 

[Roncancio]

Eigenlijk zoek ik een macro die vanuit gesloten bestanden gegevens van een specifiek tabblad haalt en verzamelt naar een nieuw bestand.

Met ExecuteExcel4Macro kan je gegevens ophalen uit een gesloten bestand.
Voorbeeld:

Range("A1").Value = ExecuteExcel4Macro("'C:\[Voorbeeld]Blad1'!R7C1")

In cel A1 wordt de inhoud van cel A7 van het werkblad Blad1 van het gesloten bestand Voorbeeld geplaatst.
In Verkenner blijft de datum en tijdstip van Gewijzigd Op van het bestand Voorbeeld onveranderd.

Bovenstaande code is hardgecodeerd.
Wat flexibeler zou het er zo kunnen uitzien.

Sub ophalen()
Dim sPad As String
Dim sBestand As String
Dim sWerkblad As String
Dim sCelVerw As String
sPad = "C:\"
sBestand = "Voorbeeld"
sWerkblad = "Blad1"
sCelVerw = "A7"

Range("A1").Value = ExecuteExcel4Macro("'" & sPad & "[" & sBestand & "]" & _
        sWerkblad & "'!" & Range(sCelVerw).Address(True, True, xlR1C1))

End Sub

Met vriendelijke groet,


Roncancio