Live-Forum - Die aktuellen Beiträge
Datum
Titel
17.06.2024 19:56:24
17.06.2024 19:39:46
Anzeige
Archiv - Navigation
1100to1104
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

aus mehreren Datesätze EINER machen

aus mehreren Datesätze EINER machen
Joachim
Hallo zusammen,
vielleicht kann mir jemand helfen: Ich habe eine Excelmappe mit Daten ab Zeile 15.
Jede Zeile ist immer ein Datensatz. Ein Datesatz sieht so aus (ich nenn nur mal die betroffenen Zellen):
Spalte D :
reiner Text (string) zB: "LAGER"
Spalte E :
Preis (Zahl) zB: "10.000-"
Spalte V :
Kriterium (string) zB: "S1", "S2", "S3" , "S4" usw. "G1", "G2" usw. "X" oder
Die restlichen Spalten von A bis V, die hier nicht erwähnt sind , brauche hier nicht beachtet werden.
Folgendes Problem: Ich suche eine Möglichkeit, mit einem Makro, Datensätze zusammen zu fassen , und zwar
folgendermassen:
Das Makro soll alle Datensätze mit gleichem Kriterium in der Spalte V suchen.
Alle Datensätze mit "X" oder die LEER sind, sollen NICHT berücksichtigt werden.
Das Makro hat nun mehrerer Datensätze mit gleichem Kriterium gefunden. Aus diesen gefundenen Datensätzen
soll nun einer gemacht werden.
Man nimmt am besten den ersten gefundenen Datensatz,
sammelt in der Spalte D alle Strings der gefundenen Datensätze. (getrennt durch ";")
Addiert in der Spalte E die Preise der gefundenen Datensätze
und löscht die restlichen raus, dass ich nur noch einen gemeinsamen Datensatz habe.
Beispiel:
SpalteD________SpalteE_________SpalteV
aus:
LAGER__________1000,-__________S1
AUTO___________2000,-__________G1
HAUS___________1000,-__________S1
BAUM___________3000,-__________X
STRAUCH________5000,-__________G1
wird:
LAGER;_HAUS____2000,-__________S1
AUTO;_STRAUCH__7000,-__________G1
BAUM___________3000,-__________X
Falls diese Darstellung schlecht gewählt war, würde ich natürlich eine Beispiel ExcelDatei bauen.
Ich hoffe, mir kann jemand helfen. Meine Makrokenntnisse reichen wirklich nicht aus.
Danke euch mal
Gruss
Joachim

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
bitte um Beispieldatei oT.
14.09.2009 14:27:52
Tino
Gerne, gleich .... owT
14.09.2009 14:30:07
Joachim
Nachfrage
14.09.2009 14:58:08
Tino
Hallo,
oben schreibst Du die Daten fangen in Zeile 15 an,
in Deinem Beispiel fangen diese schon in Zeile 10 an, was ist richtig?
Gruß Tino
Sorry, 10 ist richtig owT
14.09.2009 14:59:20
Joachim
sieht gut aus :-))
14.09.2009 18:28:13
Joachim
Hallo Tino,
Vielen Dank, mein erster Test gerade viel sehr positiv aus :-)
Um es aber ganz genau testen zu können, brauche ich noch andere Daten, die sind mir aber erst Morgen zugänglich.
Ich melde mich morgen nochmal.
Eine kleine Bitte: damit ich Dein Beispiel ein bisschen verstehe, kannst Du vielleicht ein paar Kommentare rein machen, damit ich sehe, wo was passiert. Wäre super nett.
Arbeitest Du da irgend wie mit Hilfsspalten, wo das Ergebnis ermittelt wird, dann wieder zurück geschrieben und die Spalte wieder löschen ? So irgendwie ?
Danke
Joachim
Anzeige
AW: sieht gut aus :-))
14.09.2009 18:59:34
Tino
Hallo,
Du hast recht ich arbeite mit einer Hilfsspalte am Ende der Tabelle,
diese wird zum Schluss komplett gelöscht.
Habe mal bar Kommentare reingeschrieben, hoffe kommst damit zurecht.
Die härteste Nuss ist den Text zusammenzuführen.
Sub Aufbereiten()
Dim Bereich As Range
Dim LRow As Long, A As Long, B As Long, varRow
Dim meAR1, meAR2, meAr3
Dim iCalc As Integer

With Application
  iCalc = .Calculation 'merke einstellung Berechnung auto o. manuell 
 .ScreenUpdating = False 'Bildschirmaktualisierung aus 
 .EnableEvents = False   'Events aus 
 .Calculation = xlCalculationManual 'Berechnung auf Manuell stellen 
 
    With Sheets("Tabelle1") 'Tabellennamen anpassen 
      'prüfen ob Daten ab Zeile 11 vorhanden sind 
      If .Cells(.Rows.Count, 22).End(xlUp).Row > 10 Then
        'verweis auf letzte Spalte in Tabelle (Hilfsspalte) 
        'unter xl2007 ist die Spalte 256, ab xl2007 ist dies Spalte 16384 
        With .Range("V10", .Cells(.Rows.Count, 22).End(xlUp)).Offset(0, .Columns.Count - 22)
                  meAR1 = .Offset(0, -(.Column - 4)) 'Hilfs- Array1 füllen (Spalte D) 
                  meAR2 = .Offset(0, -(.Column - 22)) 'Hilfs- Array2 füllen (Spalte V) 
                  meAr3 = .Offset(0, -(.Column - 22)) 'Hilfs- Array3 füllen (Spalte V) 
                  
                  'hier werden die Texte zusammengefasst, 
                  For A = 1 To Ubound(meAR1)
                    'ist in Sp. V ein X oder ist diese leer? 
                    If meAR2(A, 1) <> "" And meAR2(A, 1) <> "X" Then
                            B = A 'Hilfszähler 
                            varRow = Application.Match(meAR2(A, 1), meAr3, 0) 'suche weitere davon 
                           
                           Do While IsNumeric(varRow) 'Schleife bis keine Treffer mehr 
                                'ist in Sp. V ein X oder ist diese leer? 
                                If meAR2(varRow, 1) <> "" And meAR2(varRow, 1) <> "X" Then
                                  If B > A Then 'erst ab zweiten Treffer 
                                   meAR1(A, 1) = meAR1(A, 1) & ";" & meAR1(varRow, 1) 'Text zusammenführen 
                                  End If
                                End If
                                'was anderes schreiben damit wert nicht zweimal gefunden wird 
                                meAr3(varRow, 1) = "@@@@@"
                                'Suche weiter in Liste 
                                varRow = Application.Match(meAR2(A, 1), meAr3, 0)
                                B = B + 1 'Hilfszähler ein hoch 
                           Loop
                     
                     End If
                  Next A
                  'Letzte Zeile? 
                  LRow = .Rows(.Rows.Count).Row
                  'Formel für die Summierung der Werte 
                 .FormulaR1C1 = "=IF(OR(RC22="""",RC22=""X""),RC5,IF(COUNTIF(R10C22:RC22,RC22)=1," & _
                                "SUMIF(R10C22:R" & LRow & "C22,RC22,R10C5:R" & LRow & "C5),""""))"
                 
                  'Ergebnis zurückschreiben in Bereich 
                 .Offset(0, -(.Column - 5)).Value = .Value
                  'zusammengeführte Texte in Zellen zurückschreiben 
                 .Offset(0, -(.Column - 4)) = meAR1
                 'Formel erstellen um immer den ersten Eintrag zu ermitteln 
                 .FormulaR1C1 = "=IF(OR(COUNTIF(R10C22:RC22,RC22)=1,RC22="""",RC22=""X""),ROW(),TRUE)"
                  'Tebellenname Zelle, damit nicht doppelt angegeben werden muss 
                  With Sheets(.Parent.Name)
                  'Sortiere den gesamten Bereich, Zeilen die gelöscht werden kommen nach unten 
                   .Range("A10", .Cells(LRow, .Columns.Count)).Sort Key1:=.Cells(10, .Columns.Count), Order1:=xlAscending, Header:=xlNo
                  End With
     
                  
                   On Error Resume Next
                    'Zeilen löschen die das Ergebnis Wahr haben 
                    .SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
                    'Hilfsspalte komplett löschen 
                    .EntireColumn.Delete
                   On Error GoTo 0
                    
            
        End With
        'optimale Spaltenbreite 
        .Range("A:V").Columns.AutoFit
       
       End If
     
    End With

 .Calculation = iCalc 'Berechnung auf alten zustand zurückstellen 
 .ScreenUpdating = True 'Bildschirmakt. an 
 .EnableEvents = True   'Events an 
End With
End Sub
Gruß Tino
Anzeige
AW: sieht gut aus :-))
14.09.2009 19:11:06
Joachim
Hallo Tino,
ja, vielen Dank. Das Hilft mir weiter. Wenn ich auch von meinen Qualifikationen nicht alles ganz verstehe, aber grob, das ist OK.
Wie gesagt, werds morgen noch mal testen und melde mich auf jeden Fall noch mal.
Vielen vielen dank nochmals, ich gehe davon aus, das passt . :-))
Bis Morgen
Joachim
falls notwendig
14.09.2009 19:15:08
Tino
Hallo,
wenn es in der Zeile D doppelte Einträge gibt, kannst Du dies mit diesem Code vermeiden.
Sonst steht z. Bps. nachher in der Liste Strauch;10 X Rad;Strauch.
Sub Aufbereiten()
Dim Bereich As Range
Dim LRow As Long, A As Long, B As Long, varRow
Dim meAR1, meAR2, meAr3
Dim iCalc As Integer

With Application
  iCalc = .Calculation
 .ScreenUpdating = False
 .EnableEvents = False
 .Calculation = xlCalculationManual
 
    With Sheets("Tabelle1") 'Tabellennamen anpassen 
      If .Cells(.Rows.Count, 22).End(xlUp).Row > 10 Then
        With .Range("V10", .Cells(.Rows.Count, 22).End(xlUp)).Offset(0, .Columns.Count - 22)
                  meAR1 = .Offset(0, -(.Column - 4))
                  meAR2 = .Offset(0, -(.Column - 22))
                  meAr3 = .Offset(0, -(.Column - 22))
                  
                  For A = 1 To Ubound(meAR1)
                    meAR1(A, 1) = ";" & meAR1(A, 1) & ";"
                    If meAR2(A, 1) <> "" And meAR2(A, 1) <> "X" Then
                            B = A
                            varRow = Application.Match(meAR2(A, 1), meAr3, 0)
                           
                           Do While IsNumeric(varRow)
                                If meAR2(varRow, 1) <> "" And meAR2(varRow, 1) <> "X" Then
                                  If B > A Then
                                   If Not meAR1(A, 1) Like "*;" & meAR1(varRow, 1) & ";*" Then
                                     meAR1(A, 1) = meAR1(A, 1) & meAR1(varRow, 1) & ";"
                                   End If
                                  End If
                                End If
                                
                                meAr3(varRow, 1) = "@@@@@"
                                varRow = Application.Match(meAR2(A, 1), meAr3, 0)
                                B = B + 1
                           Loop
                     
                     End If
                     If Right$(meAR1(A, 1), 1) = ";" Then meAR1(A, 1) = Left$(meAR1(A, 1), Len(meAR1(A, 1)) - 1)
                     If Left$(meAR1(A, 1), 1) = ";" Then meAR1(A, 1) = Right$(meAR1(A, 1), Len(meAR1(A, 1)) - 1)
                  Next A
                  
                  LRow = .Rows(.Rows.Count).Row
                 
                 .FormulaR1C1 = "=IF(OR(RC22="""",RC22=""X""),RC5,IF(COUNTIF(R10C22:RC22,RC22)=1," & _
                                "SUMIF(R10C22:R" & LRow & "C22,RC22,R10C5:R" & LRow & "C5),""""))"
                 
                 .Offset(0, -(.Column - 5)).Value = .Value
                 .Offset(0, -(.Column - 4)) = meAR1
                 .FormulaR1C1 = "=IF(OR(COUNTIF(R10C22:RC22,RC22)=1,RC22="""",RC22=""X""),ROW(),TRUE)"
                  
                  With Sheets(.Parent.Name)
                   .Range("A10", .Cells(LRow, .Columns.Count)).Sort Key1:=.Cells(10, .Columns.Count), Order1:=xlAscending, Header:=xlNo
                  End With
                  
                  
                  
                  
                   On Error Resume Next
                    .SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
                    .EntireColumn.Delete
                   On Error GoTo 0
                    
            
        End With
        .Range("A:V").Columns.AutoFit
       
       End If
     
    End With

 .Calculation = iCalc
 .ScreenUpdating = True
 .EnableEvents = True
End With
End Sub
Gruß Tino
Anzeige
AW: falls notwendig
15.09.2009 08:28:04
Joachim
Hallo Tino,
bin gerade noch am testen.
Frage, zuwas trägst du mit der Formel in der Spalte IV die Zahlen und "WAHR" ein ?
Mir ist noch nicht ganz klar, wo die Daten zusammengeschrieben werden, in einem Array, sehe ich das garnicht ?
Gruss
Joachim
AW: falls notwendig
15.09.2009 08:55:42
Tino
Hallo,
die Sache ist ganz einfach, ich suche mir mit der Formel immer das erste vorkommen eines Begriffes aus Spalte V oder wenn diese X oder leer ist bekommt diese Zeile die Zeilennummer,
die anderen Zellen bekommen den Wert Wahr.
Jetzt kann ich den Bereich sortieren und die Zeilen mit Wahr in IV stehen ganz unten,
diese Zeilen kann ich nun als Block löschen.
Grund dafür ist, zusammenhängende Zeilen lassen sich schneller löschen als wild verstreute.
Durch die Zeilennummer ist gewährleistet,
dass die Zeilen die alte Reihenfolge durchs sortieren beibehalten.
 VIV
9Kategorien 
10X10
11S2  BTT11
12X12
13 13
14S2  BTTWAHR
15S1  REG15
16S1  REGWAHR
17S2  BTTWAHR
18S3  SPD18
19S3  SPDWAHR
20X20
21S2  BTTWAHR

Formeln der Tabelle
ZelleFormel
IV10=WENN(ODER(ZÄHLENWENN($V$10:$V10;$V10)=1;$V10="";$V10="X"); ZEILE(); WAHR)
IV11=WENN(ODER(ZÄHLENWENN($V$10:$V11;$V11)=1;$V11="";$V11="X"); ZEILE(); WAHR)
IV12=WENN(ODER(ZÄHLENWENN($V$10:$V12;$V12)=1;$V12="";$V12="X"); ZEILE(); WAHR)
IV13=WENN(ODER(ZÄHLENWENN($V$10:$V13;$V13)=1;$V13="";$V13="X"); ZEILE(); WAHR)
IV14=WENN(ODER(ZÄHLENWENN($V$10:$V14;$V14)=1;$V14="";$V14="X"); ZEILE(); WAHR)
IV15=WENN(ODER(ZÄHLENWENN($V$10:$V15;$V15)=1;$V15="";$V15="X"); ZEILE(); WAHR)
IV16=WENN(ODER(ZÄHLENWENN($V$10:$V16;$V16)=1;$V16="";$V16="X"); ZEILE(); WAHR)
IV17=WENN(ODER(ZÄHLENWENN($V$10:$V17;$V17)=1;$V17="";$V17="X"); ZEILE(); WAHR)
IV18=WENN(ODER(ZÄHLENWENN($V$10:$V18;$V18)=1;$V18="";$V18="X"); ZEILE(); WAHR)
IV19=WENN(ODER(ZÄHLENWENN($V$10:$V19;$V19)=1;$V19="";$V19="X"); ZEILE(); WAHR)
IV20=WENN(ODER(ZÄHLENWENN($V$10:$V20;$V20)=1;$V20="";$V20="X"); ZEILE(); WAHR)
IV21=WENN(ODER(ZÄHLENWENN($V$10:$V21;$V21)=1;$V21="";$V21="X"); ZEILE(); WAHR)

Gruß Tino
Anzeige
Hallo Tino, Alles Perfekt, VIELEN VIELEN DANK owT
15.09.2009 14:33:12
Joachim

305 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige