Macro voor samenvoegen excel bestanden

[hermes79]

Ik ben niet zo onderlegd in macro's, maar ik heb alvast de onderstaande kunnen samenstellen.
Deze moet excel bestanden binnen één werkmap samenvoegen in één worksheet.

Deze werkt goed, maar ik wens nog 2 dingen te wijzigen
- dat enkel de rijen (uit de diverse bestanden) worden gekopieerd waar de waarde in kolom A "1" is
- dat enkel de waarden worden gekopieerd en niet de formules

Sub MergeUsedRanges()
Dim wbSource As Workbook, wbTarget As Workbook
Dim shTarget As Worksheet
Dim sPath As String, sFileMask As String, sTargetFile As String
Dim sFileName As String
Dim bIncludeHeaders As Boolean, lTargetRow As Long, r As Range

sPath = ActiveWorkbook.Path
sFileMask = "*.xls"
sPath = sPath & "\"
sFileName = Dir(sPath & sFileMask)

If sFileName <> "" Then
Set wbTarget = Workbooks.Add
Set shTarget = wbTarget.Worksheets(1)
End If
lTargetRow = 2
Do Until sFileName = ""

Set wbSource = Workbooks.Open(Filename:=sPath & sFileName)

Set r = wbSource.Sheets(1).UsedRange

If r.Rows.Count > 0 Then
If bIncludeHeaders = True Then
bIncludeHeaders = False
Else
Set r = r.Offset(4, 0).Resize(24 - 4, r.Columns.Count)
End If
r.Copy Destination:=shTarget.Cells(lTargetRow, 2)
lTargetRow = lTargetRow + r.Rows.Count

End If
wbSource.Close
sFileName = Dir

Loop

Application.DisplayAlerts = False
wbTarget.SaveAs Filename:=sPath & sTargetFile
Application.DisplayAlerts = True
wbTarget.Close
End Sub

bedankt

 

[Cobbe]

Maar je hebt nog niet geleerd om code leesbaar te posten.

 

[roeljongman]

Deze regel moet je denk splitsen

r.Copy Destination:=shTarget.Cells(lTargetRow, 2)

Volgens moet je als je alleen waarden wilt plakken, je dan 2 regels moeten gebruiken

r.Copy Destination:=shTarget.Cells(lTargetRow, 2)
shTarget.Cells(lTargetRow, 2).copy
shTarget.Cells(lTargetRow, 2).PasteSpecial Xlvalues

Op deze manier word alles gekopieerd en daarna kopieer en plak je het gebied nog een keer om alles om te zetten naar vaste waarden, maar door deze methode komt wel de opmaak ook mee. Er is ook een andere optie

r.Copy 
shTarget.Cells(lTargetRow, 2).PasteSpecial xlPasteValues

maar dan mis je de opmaak van het bronbestand.. wel is het mogelijk door nog een regel op te nemen met xlPasteFormats zodat ook de opmaak meekomt.. en eventueel nog wat andere instellingen. maar daarom leek mij de eerste


Voor je andere vraag over het alleen kopieren van regels waar in kolom A een 1 staat.. dacht ik aan het volgende..
Als ik je code goed lees worden er nu altijd 20 rijen gekopieerd door regel "Set r = r.Offset(4, 0).Resize(24 - 4, r.Columns.Count)"

Ik zou die kopieer actie gewoon intact laten en dan na het kopieren de regels die niet aan het criterium voldoen verwijderen met een loopje..

For i = 1 To 20
    If shTarget.Cells(lTargetRow, 1).Value <> 1 Then
        shTarget.Cells(lTargetRow, 1).EntireRow.Delete
    End If
Next i

of dit de exact juiste code is moet je even testen maar in deze richting moet de oplossing wel liggen en als het hiermee niet lukt plaats dan even een voorbeeldje zodat er meer gericht gekeken kan worden.