samenvoegen excel bestanden in bepaalde directory

[HSV]

Bestaat deze map 'attachments'?

"h:\attachments\

 

[enrico85]

Yes de map bestaat en hij maakt ook een nieuwe excel bestand aan in deze map zoals in de code staat. Alleen daarna krijg je een foutcode en dan doet die niets meer en heeft die ook geen gegevens in het nieuwe bestand gezet.

groeten
enrico

 

[enrico85]

Het lijkt erop dat die vast loopt op Sheets(1) dit heb ik allemaal veranderd naar Blad1 en dan geeft die aan:

Fout 438 tijdens uitvoering:

Deze eigenschap of methode wordt niet ondersteund door dit object

Als ik dan naar foutopsporing ga, arceert die de volgende zin geel

'Workbooks(Bestandopen).Blad1.UsedRange.Copy Workbooks("nieuw " & naam & ".xlsx").Blad1.Cells(Blad1.UsedRange.Rows.Count, 1).End(xlUp).Offset(1)

 

[HSV]

Zo heb ik die coderegel in #23 niet geschreven toch?

Waarom neem je niet de code gewoon over ipv zelf goochelen.

 

[enrico85]

Nee klopt inderdaad. Maar hij doet het bij mij niet, dus dan ga ik zelf beetje goochelen. Kan ik beter niet meer doen

Heb nu jou code weer

Sub hsv()
Dim Bestandopen As String, naam As String
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
   Workbooks.Add
   naam = Format(Now, "dd-mm-yyyy hh_mm_ss")
  ActiveWorkbook.SaveAs "h:\attachments\nieuw " & naam, 51 '?
Bestandopen = Dir("h:\attachments\*")  ' ?
Do Until Bestandopen = ""
        If Bestandopen <> ThisWorkbook.Name Then
            Workbooks.Open "h:\attachments\" & Bestandopen    ' ?
            Workbooks(Bestandopen).Sheets(1).UsedRange.Copy Workbooks("nieuw " & naam & ".xlsx").Sheets(1).Cells(Sheets(1).UsedRange.Rows.Count, 1).End(xlUp).Offset(1)
            Workbooks(Bestandopen).Close False
        End If
     Bestandopen = Dir
    Loop
     Workbooks("nieuw " & naam & ".xlsx").Sheets(1).Columns.AutoFit
     Workbooks("nieuw " & naam & ".xlsx").Close True
 .DisplayAlerts = True
End With
End Sub

Heb nu alleen de bestandnaam aangepast en dan komt die met de met de foutmelding

Fout 9 tijdens uitvoering:

Het subscript valt buiten bereik

En dan arceert die de volgende regel

Workbooks("nieuw " & naam & ".xlsx").Sheets(1).Columns.AutoFit

De map bestaat wel want hij maakt wel het nieuwe bestand aan.

 

[HSV]

Hallo Enrico,

Beetje goochelen kan geen kwaad, maar ik weet op een gegeven moment niet meer waar ik naar toe moet werken.

Ik ben er al uit volgens mij:
Je nieuwe bestand wordt geplaatst in dezelfde map, daarna wordt het bestand weer aangeroepen aan in de code.


Verander eens onderstaande coderegel.......

If Bestandopen <> ThisWorkbook.Name then

.....in.

If Bestandopen <> ThisWorkbook.Name And Bestandopen <> "nieuw " & naam & ".xlsx" Then

 

[enrico85]

Hoi Harry,

Hij geeft nu geen meldingen meer alleen het lijkt erop dat die gegevens van de andere bestanden overschrijft.
Het resultaat begint met een stukje van test 2 en dan de gegevens van test 3 en dan alles een beetje door elkaar.
Kan er niet echt een logica uithalen.

groeten
enrico

 

[HSV]

Even testen.

Sub hsv()
Dim Bestandopen As String, naam As String, i As Long, a As Long, x As Long, xx As Long
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
   Workbooks.Add
   naam = Format(Now, "dd-mm-yyyy hh_mm_ss")
   ActiveWorkbook.SaveAs "h:\attachments\nieuw " & naam, 51 
Bestandopen = Dir("h:\attachments\*")  
Do Until Bestandopen = ""
        If Bestandopen <> ThisWorkbook.Name And Bestandopen <> "nieuw " & naam & ".xlsx" Then
            Workbooks.Open "h:\attachments\" & Bestandopen 
        With Workbooks("nieuw " & naam & ".xlsx")
         For i = 1 To .Sheets(1).UsedRange.Columns.Count
           a = .Sheets(1).Cells(Rows.Count, i).End(xlUp).Row
           If a > x Then
             x = a
             xx = i
           End If
         Next i
            Workbooks(Bestandopen).Sheets(1).Cells(1).CurrentRegion.Copy .Sheets(1).Cells(Rows.Count, xx).End(xlUp).Offset(1, -xx + 1)
            Workbooks(Bestandopen).Close False
        End With
        End If
     Bestandopen = Dir
    Loop
      Workbooks("nieuw " & naam & ".xlsx").Sheets(1).Columns.AutoFit
      Workbooks("nieuw " & naam & ".xlsx").Close True
 .DisplayAlerts = True
End With
End Sub

 

[enrico85]

Hoi Harry,

Heb het even getest.
Met deze code kopieert die alleen 3x 'Interne doorbelasting'.

groet
enrico

 

[HSV]

Hallo,

Waar kan het bij jou fout gaan waar hier alles goed verloopt.
De code opent heus geen drie keer hetzelfde werkboek.

 

[enrico85]

Hoi Harry,

Heb het nu thuis getest en dit is het resultaat (zie bijlage).

Het lijkt erop dat die alleen de cellen A1 en A2 kopieert naar het nieuwe bestand.
Bij jou kopieert die gewoon de hele werkbladen?

groeten
enrico

 

[HSV]

Hallo Enrico,

Dan heb je geen currentregion vanaf cel A1.

Verander eens....

Workbooks(Bestandopen).Sheets(1).Cells(1).CurrentRegion.Copy

....in.

Workbooks(Bestandopen).Sheets(1).usedrange.Copy

 

[enrico85]

Hoi Harry,

Heb er nu UsedRange van gemaakt en dan komt die met foutmelding:

Fout 438 tijdens uitvoering:

Deze eigenschap of methode wordt niet ondersteund door dit object

 

[HSV]

Hoi Enrico,

Vorig schrijven (#32) aangepast.

 

[enrico85]

Hoi Harry,

Hij doet het!
Is het ook mogelijk dat die de opmaak verwijderd en de formules om zet naar waardes van het nieuwe bestand dat die aanmaakt?

gr. enrico

 

[HSV]

Hoi,

Tussen 'Next' en 'Close' even aanpassen in de code.

Next i
 Workbooks(Bestandopen).Sheets(1).UsedRange.Copy
   .Sheets(1).Cells(Rows.Count, xx).End(xlUp).Offset(1, -xx + 1).PasteSpecial -4163 
Workbooks(Bestandopen).Close False

 

[enrico85]

Hoi Harry,

Bedankt voor al je hulp, het werkt prima!

groet
enrico

 

[HSV]

Graag gedaan Enrico.