Daten zusammenfügen und vergleichen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Main() Const strPath As String = "C:\Users\acer\" 'Pfad anpassen Dateien sind Dim strDateiname As String Dim wkbBook As Workbook Dim lngLastRowQ As Long Dim lngLastRowZ As Long Dim lngLastCol As Long Dim intCalc As Integer On Error GoTo Fin With Application .ScreenUpdating = False .AskToUpdateLinks = False .EnableEvents = False intCalc = .Calculation .Calculation = xlCalculationManual .DisplayAlerts = False End With 'strDateiname = Dir$(ThisWorkbook.Path & "\*.xls") strDateiname = Dir$(strPath & "*.xlsm") Do While strDateiname "" If strDateiname ThisWorkbook.Name Then Set wkbBook = Workbooks.Open(strPath & strDateiname) Call Bearbeiten wkbBook.Close False ' Oder True, wenn gespeichert werden soll Set wkbBook = Nothing End If strDateiname = Dir$() Loop Fin: Set wkbBook = Nothing With Application .ScreenUpdating = True .AskToUpdateLinks = True .EnableEvents = True .Calculation = intCalc .DisplayAlerts = True End With If Err.Number 0 Then MsgBox "Error: " & _ Err.Number & " " & Err.Description End Sub

Sub Bearbeiten() Sheets("ACTION").Select Dim Ez1 As Long 'erste Zeile (hast Du vorgegeben) Dim Lz1 As Long 'letzte Zeile (wird ermittelt) Dim Spalte1 As String Dim Spalte2 As String Spalte1 = "A" Spalte2 = "F" Ez1 = 2 'Vorgabe Lz1 = ActiveSheet.Cells(Rows.Count, Spalte2).End(xlUp).Row 'ermitellt letzte Zeile ActiveSheet.Range(Spalte1 & Ez1 & ":F" & Lz1).Copy Windows("ZUSAMMENFASSUNG.xlsm").Activate Range("F1000000").Activate Selection.End(xlUp).Select ActiveCell.Offset(-5, 1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub

Sub Bearbeiten ersetzen. Der Rest bleibt gleich. Sub Bearbeiten() Sheets("ACTION").Select Dim Ez1 As Long 'erste Zeile Dim Lz1 As Long 'letzte Zeile (wird ermittelt) Dim Spalte1 As String Dim Spalte2 As String Spalte1 = "A" Spalte2 = "E" Spalte3 = "H" Ez1 = ActiveSheet.Cells(Rows.Count, Spalte3).End(xlUp).Row + 1 'ermittelt erste Zeile Lz1 = ActiveSheet.Cells(Rows.Count, Spalte2).End(xlUp).Row + 1 'ermitellt letzte Zeile Range("H1").Select ActiveCell.FormulaR1C1 = "=IF(RC[-3]="""","""",""übernommen"")" Range("E1000000").Select Selection.End(xlUp).Select ActiveCell.Offset(0, 3).Select Range(Selection, Selection.End(xlUp)).Select Selection.FillDown ActiveSheet.Range(Spalte1 & Ez1 & ":F" & Lz1).Copy Windows("ZUSAMMENFASSUNG.xlsm").Activate Range("E1000000").Activate Selection.End(xlUp).Select ActiveCell.Offset(1, -4).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub Jetzt funktioniert es so, dass bei den Datensätzen in den ACTION-Sheets in Spalte H ein übernommen kommt. Bei nächsten durchführen des Makros werden Dann alle Zeilen ab den letzten übernommen kopiert. Das würde dann halt klappen wenn in den Excel-Sheets nur neue Zeilen hinzugefügt werden. Gruß Christoph

So vom essen zurück.
vielleicht kommen wir ja noch zu einer Lösung=)
Habe es jetzt besser gelöst und sollte nicht zu den Fehler kommen.
Hier jetzt nochmal alles.

Sub Zusammenfassen_CHRISTOPH()
'Const strPath As String = "C:\Users\acer\Desktop\Testherber\Archiv\" 'Pfad anpassen Dateien  _
sind
Const strPath As String = "J:\P_VA_VE_Cost_Reduction\TEAM_Ordner\01_Daten sammeln\06_Business  _
Case\" 'Pfad anpassen Dateien sind
Dim strDateiname As String
Dim wkbBook As Workbook
Dim lngLastRowQ As Long
Dim lngLastRowZ As Long
Dim lngLastCol As Long
Dim intCalc As Integer
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
intCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
'strDateiname = Dir$(ThisWorkbook.Path & "\*.xls")
strDateiname = Dir$(strPath & "*.xlsm")
Do While strDateiname  ""
If strDateiname  ThisWorkbook.Name Then
Set wkbBook = Workbooks.Open(strPath & strDateiname)
Call Bearbeiten
wkbBook.Close True ' Oder True, wenn gespeichert werden soll
Set wkbBook = Nothing
End If
strDateiname = Dir$()
Loop
Fin:
Set wkbBook = Nothing
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = intCalc
.DisplayAlerts = True
End With
If Err.Number  0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub

Sub Bearbeiten()
Sheets("ACTION").Select
Dim Ez1 As Long    'erste Zeile
Dim Lz1 As Long    'letzte Zeile (wird ermittelt)
Dim Spalte1 As String
Dim Spalte2 As String
Dim Zeile%
Dim x
Spalte1 = "A"
Spalte2 = "E"
Spalte3 = "H"
Ez1 = ActiveSheet.Cells(Rows.Count, Spalte3).End(xlUp).Row + 1    'ermittelt erste Zeile
Lz1 = ActiveSheet.Cells(Rows.Count, Spalte2).End(xlUp).Row + 1 'ermitellt letzte Zeile
For Zeile = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row To 1 Step -1
If Cells(Zeile, 5)  "" Then
Cells(Zeile, 8) = "übernommen"
End If
Next
ActiveSheet.Range(Spalte1 & Ez1 & ":F" & Lz1).Copy
Windows("MUSTER.xlsm").Activate
Range("E1000000").Activate
Selection.End(xlUp).Select
ActiveCell.Offset(1, -4).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub

Sub Bearbeiten2() Dim Zeile% Sheets("ACTION").Select For Zeile = ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row To 1 Step -1 If Cells(Zeile, 8) = "übernehmen" Then ActiveSheet.Range("A" & Zeile & ":F" & Zeile).Copy Cells(Zeile, 8) = "übernommen" Windows("ZUSAMMENFASSUNG1.xlsm").Activate Range("E1000000").Activate Selection.End(xlUp).Offset(1, -4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks _ :=False, Transpose:=False End If Next End Sub

Sub Zusammen() On Error GoTo Fehler Dim LR0%, LR1% Dim TB0, TB1 Dim strPath$, strExt$, strFile$ Set TB0 = ThisWorkbook.ActiveSheet strPath = "C:\Temp\ABC\" 'Pfad des Verzeichnisses ggf. anpassen strExt = "*.xlsx" 'Dateiextension ggf. anpassen strFile = Dir(strPath & strExt) 'erster Treffer Do While Len(strFile) > 0 Workbooks.Open FileName:=strPath & strFile For Each TB1 In Worksheets ' Alle Tabellenblätter prüfen If InStr(TB1.Name, "ACTION") > 0 Then LR1 = TB1.Cells.SpecialCells(xlCellTypeLastCell).Row LR0 = TB0.Cells.SpecialCells(xlCellTypeLastCell).Row + 1 TB1.Range("A2:F" & LR1).Copy TB0.Cells(LR0, 1) End If Next TB1 Workbooks(strFile).Close savechanges:=False strFile = Dir() 'nächster Treffer Loop Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Sub Bearbeiten() Sheets("ACTION").Select Dim Ez1 As Long 'erste Zeile (hast Du vorgegeben) Dim Lz1 As Long 'letzte Zeile (wird ermittelt) Dim Spalte1 As String Dim Spalte2 As String Spalte1 = "A" Spalte2 = "F" Ez1 = 2 'Vorgabe Lz1 = ActiveSheet.Cells(Rows.Count, Spalte2).End(xlUp).Row 'ermitellt letzte Zeile ActiveSheet.Range(Spalte1 & Ez1 & ":F" & Lz1).Copy Windows("ZUSAMMENFASSUNG.xlsm").Activate Range("F1000000").Activate Selection.End(xlUp).Select ActiveCell.Offset(1, -5).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub

Sub Alle_Blätter_alle_Dateien() On Error GoTo Fehler Dim LR0%, LR1% Dim TB0, TB1 Dim strPath$, strExt$, strFile$ Set TB0 = ThisWorkbook.ActiveSheet strPath = "C:\Temp\ABC\" 'Pfad des Verzeichnisses ggf. anpassen strExt = "*.xlsx" 'Dateiextension ggf. anpassen strFile = Dir(strPath & strExt) 'erster Treffer Do While Len(strFile) > 0 If strFile ThisWorkbook.Name Then Workbooks.Open FileName:=strPath & strFile For Each TB1 In Worksheets ' Alle Tabellenblätter prüfen If InStr(TB1.Name, "ACTION") > 0 Then LR1 = TB1.Cells.SpecialCells(xlCellTypeLastCell).Row LR0 = TB0.Cells.SpecialCells(xlCellTypeLastCell).Row + 1 TB1.Range("A2:F" & LR1).Copy With TB0.Cells(LR0, 1) .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _ , SkipBlanks:=False, Transpose:=False 'Formate .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Werte Application.CutCopyMode = False End With End If Next TB1 Workbooks(strFile).Close savechanges:=False End If strFile = Dir() 'nächster Treffer Loop Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Sub Alle_Blätter_alle_Dateien() On Error GoTo Fehler Dim LR0%, LR1% Dim TB0, TB1 Dim strPath$, strExt$, strFile$ Set TB0 = ThisWorkbook.ActiveSheet strPath = "C:\Temp\ABC\" 'Pfad des Verzeichnisses ggf. anpassen strExt = "*.xlsx" 'Dateiextension ggf. anpassen strFile = Dir(strPath & strExt) 'erster Treffer Do While Len(strFile) > 0 If strFile ThisWorkbook.Name Then Workbooks.Open Filename:=strPath & strFile Set TB1 = ActiveWorkbook.Sheets("ACTION") LR1 = TB1.Cells.SpecialCells(xlCellTypeLastCell).Row LR0 = TB0.Cells.SpecialCells(xlCellTypeLastCell).Row + 1 TB1.Range("A2:F" & LR1).Copy With TB0.Cells(LR0, 1) .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _ , SkipBlanks:=False, Transpose:=False 'Formate .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False 'Werte Application.CutCopyMode = False End With Workbooks(strFile).Close savechanges:=False End If strFile = Dir() 'nächster Treffer Loop Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Beliebteste Forumthreads (12 Monate)

Daten zusammenfügen und vergleichen

36 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

36
Beiträge zum Forumthread

Beiträge zu diesem Forumthread