Makro gesucht

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Summe() Sheets(2).Cells(1, 1).Value = "Termin" Sheets(2).Cells(1, 2).Value = "KdNr" Sheets(2).Cells(1, 3).Value = "KdTxt" Sheets(2).Cells(1, 4).Value = "ArtNr" Sheets(2).Cells(1, 5).Value = "Summe" lZ1 = Sheets(1).Range("A1").End(xlDown).Row For i = 1 To lZ1 Z1 = 0 lZ2 = Sheets(2).Range("A1").End(xlDown).Row T1 = Sheets(1).Cells(i, 1).Value F1 = Sheets(1).Cells(i, 2).Value K1 = Sheets(1).Cells(i, 3).Value A1 = Sheets(1).Cells(i, 4).Value B1 = Sheets(1).Cells(i, 5).Value For j = 2 To lZ2 If T1 = Sheets(2).Cells(j, 1).Value Then If F1 = Sheets(2).Cells(j, 2).Value Then If A1 = Sheets(2).Cells(j, 4).Value Then Sheets(2).Cells(j, 5).Value = Sheets(2).Cells(j, 5).Value + B1 Z1 = 0 Else Z1 = Z1 + 1 End If Else Z1 = Z1 + 1 End If Else Z1 = Z1 + 1 End If Next If Z1 > 0 Then Sheets(2).Cells(lZ2 + 1, 1).Value = T1 Sheets(2).Cells(lZ2 + 1, 2).Value = F1 Sheets(2).Cells(lZ2 + 1, 3).Value = K1 Sheets(2).Cells(lZ2 + 1, 4).Value = A1 Sheets(2).Cells(lZ2 + 1, 5).Value = B1 End If Next End Sub

hallo maria,
folgender code ist zu 98% HaJos werk.
habe ihn nur deinen bedürfnissen angepasst.
es wird ein neues tabellenblatt mit deiner zusammenfassung erzeugt.

Sub loeschen()
Dim LoAnzahl As Long                                        ' Variable ob Datensatz doppelt
Dim Loletzte As Long                                    ' Variable letzte Zeile
Dim LoI As Long                                         ' Schleifenvariable Zeile
Dim LoJ As Long                                         ' Schleifenvariable Spalte
' Variable ob doppelt für aktuellen  _
Datensatz
Dim ByAnzahl As Byte
Application.ScreenUpdating = False                      ' Bildschirmanzeige aus
' letzte Zeile feststellen
Loletzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
' alte Tabelle "Neu" löschen,  _
Tabelle1 kopieren und umbenennen in "Neu"
On Error Resume Next                                    ' Fehlerbehandlung ausschalten
Application.DisplayAlerts = False                       ' Mitteilungen aus
Worksheets("Neu").Delete                                ' Tabelle "Neu" löschen
Application.DisplayAlerts = True                        ' Mitteilungen ein
On Error GoTo 0                                         ' Fehlerbehandlung einschalten
ActiveSheet.Copy Before:=Worksheets(1)                  ' aktuelle Tabelle kopieren und vor  _
die 1. Tabelle einfügen
With ActiveSheet
.Name = "Neu"                                       ' Tabelle in "Neu" umbenennen
End With
' Sortieren der Daten nach Spalte A  _
und B ohne Überschrift
Range("A1:E8000").Sort Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("B1"), Order1:=xlAscending, Key3:=Range("D1"), Order1:=xlAscending, Header:= _
xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' Variable auf 1, Kennzeichen  _
erster Datensatz
LoAnzahl = 1
' Schleife über alle Zeilen, von  _
der letzten bis zu ersten
For LoI = Loletzte - 1 To 1 Step -1
ByAnzahl = 0                                        ' Variable für Doppelt auf 0
' Schleife von Spalte A bis Spalte  _
D
For LoJ = 1 To 4
' jeden Wert der Spalte mit dem  _
Wert der Zelle darüber vergleichen
If Cells(LoI, LoJ) = Cells(LoI + 1, LoJ) Then
ByAnzahl = ByAnzahl + 1                     ' Zellen stimmen überein
End If
Next LoJ
' stimmen 4 Werte überein ist die  _
Zeile doppelt
If ByAnzahl = 4 Then
Cells(LoI + 1, 5) = Cells(LoI + 1, 5) + Cells(LoI, 5)
Rows(LoI).Delete                                ' Zeile löschen
LoAnzahl = LoAnzahl + 1                         ' doppelte Datensätze zählen
Else
' Datensatz ist doppelt, löschen
'If LoAnzahl > 1 Then Rows(LoI + 1).Delete
LoAnzahl = 1
' Variable für doppelt auf 1 setzen
End If
Next LoI
Application.ScreenUpdating = True                       ' Bildschirmanzeige ein
End Sub

gruß
selli

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread