Excel nach Inhalt per VBA umschreiben

Forumthread: Excel nach Inhalt per VBA umschreiben

27.09.2007 15:15:40

Thomas

Hallo,
Ich habe hier keinen Plan wie ich das lösen soll:
Ich habe folgende Daten als Excel-Sheet welche umsortiert werden sollen.
LINK: https://www.herber.de/bbs/user/46389.xls
Ich benötige pro ID (Spalte 1) (welche sortiert mehrfach vorkommen) eine Zeile mit den Inhalten der gleichen ID's am Ende der Zeile.
Die Abfrage müsste meines Erachtens so gehen:
Zeile 1 Feld ID merken im Speicher dann ganze Zeile rausschreiben in Zeile 1 in neue Tabelle4
Zeile 2 Feld ID gleich vorhergehendes Feld dann Feld TEXT und BETRAG appenden an Zeile 1 in Tabelle4
Zeile 3 Feld ID gleich vorhergehendes Feld dann Feld TEXT und BETRAG appenden an Zeile 1 in Tabelle4
Zeile 4 Feld ID ungleich vorhergehendes Feld dann Zeile rausschreiben in Zeile 2 in Tabelle4
and so on
Kann mir da jemand die richtigen Codeschnippsel für ein Makro verraten?
Herzlichen Dank
Thomas Leitner

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sollen denn immer ALLE Spalten (A:L) kopiert...

27.09.2007 15:31:00

NoNet

...werden ?
Hallo Thomas,
die Zeilen enthalten ja pro ID immer unterschiedliche Daten in Spalten C und D, alle anderen Spalten sind bei gleicher ID identisch.
Genügt es, die Spalten A:B und E:L immer nur 1x zu kopieren und bei wiederholender ID nur die Spalten C:D anzuhängen ?
Du weißt aber schon, dass Excel (bis Version 2003) nur max. 256 Spalten hat, oder ?
Gruß, NoNet

AW: Sollen denn immer ALLE Spalten (A:L) kopiert...

27.09.2007 15:51:30

Thomas

Hallo NoNet,
vielen Dank für die rasche Antwort.
"Genügt es, die Spalten A:B und E:L immer nur 1x zu kopieren und bei wiederholender ID nur die Spalten C:D anzuhängen ?"
Ja es genügt völlig die relevanten Zellen hinten anzuhängen.
Übrigens das Excel Sheet hat über 4000 Zeilen !
"Du weißt aber schon, dass Excel (bis Version 2003) nur max. 256 Spalten hat, oder ?"
Jetzt schon...... ;-) Es sind aber derzeit max. 5 Positionen pro ID.
mfg Thomas Leitner

Liste umsortieren per VBA (ohne ARRAYS)

27.09.2007 16:38:22

NoNet

Hallo Thomas,
ich habe Dein "TOOL" mal ein wenig umprogrammiert, es heißt nun "TOLL" ;-) :

Sub TOLL()
    'Das TOOL in einer Version von NoNet (www.excelei.de), 27.09.2007 bei herber.de
    Dim shDaten As Worksheet, shListe As Worksheet
    Dim Zeile, Zeilen, zeNeu, spNeu
    Dim IDgefunden
    Set shDaten = Sheets("Tabelle1") 'Dies ist das Ursprungsblatt
    Set shListe = Sheets.Add         'Das ist das neue Blatt
    shDaten.[1:1].Copy shListe.[A1]  'Überschriften kopieren
    zeNeu = 1
    On Error Resume Next 'falls ID noch nicht gefunden wurde
    Zeilen = shDaten.Cells(Rows.Count, "A").End(xlUp).Row 'Anzahl Zeilen ermitteln
    For Zeile = 2 To Zeilen 'In Zeile 1 steht die Überschrift
        IDgefunden = 0
        IDgefunden = Application.WorksheetFunction.Match(shDaten.Cells(Zeile, "A"), _
            shListe.[A:A], 0)
        If IDgefunden > 0 Then
            spNeu = shListe.Cells(IDgefunden, Columns.Count).End(xlToLeft).Column
            shDaten.Cells(Zeile, "C").Resize(1, 2).Copy shListe.Cells(IDgefunden, spNeu + 1)
            shDaten.[B1:C1].Copy shListe.Cells(1, spNeu + 1)
        Else
            zeNeu = zeNeu + 1
            shDaten.Rows(Zeile).Copy shListe.Rows(zeNeu)
        End If
    Next
    shListe.Columns.AutoFit
    Set shDaten = Nothing
    Set shListe = Nothing
End Sub
Ich hoffe mal, das ist das, was Du wolltest ?!?!?
Gruß, NoNet

2 kleine Korrekturen, hier der Code

27.09.2007 17:11:00

NoNet

Hallo Thomas,
hatte versehentlich Spalten B und C anstatt C und D kopiert.
Ausserdem sieht es besser aus, wenn der erste Buchungsbetrag+Text auch hinten (vor dem 2. Betrag) erscheint, daher habe ich ihn noch per "Cut&Paste" verschoben. Hier nun der aktuelle Code :

Sub TOLL()
    'Das TOOL in einer Version von NoNet (www.excelei.de), 27.09.2007 bei herber.de
    Dim shDaten As Worksheet, shListe As Worksheet
    Dim Zeile, Zeilen, zeNeu, spNeu
    Dim IDgefunden
    Set shDaten = Sheets("Tabelle1") 'Dies ist das Ursprungsblatt
    Set shListe = Sheets.Add         'Das ist das neue Blatt
    shDaten.[1:1].Copy shListe.[A1]  'Überschriften kopieren
    zeNeu = 1
    On Error Resume Next 'falls ID noch nicht gefunden wurde
    Zeilen = shDaten.Cells(Rows.Count, "A").End(xlUp).Row 'Anzahl Zeilen ermitteln
    For Zeile = 2 To Zeilen 'In Zeile 1 steht die Überschrift
        IDgefunden = 0
        IDgefunden = Application.WorksheetFunction.Match(shDaten.Cells(Zeile, "A"), _
            shListe.[A:A], 0)
        If IDgefunden > 0 Then
            spNeu = shListe.Cells(IDgefunden, Columns.Count).End(xlToLeft).Column
            shDaten.Cells(Zeile, "C").Resize(1, 2).Copy shListe.Cells(IDgefunden, spNeu + 1)
            shDaten.[C1:D1].Copy shListe.Cells(1, spNeu + 1)
        Else
            zeNeu = zeNeu + 1
            shDaten.Rows(Zeile).Copy shListe.Rows(zeNeu)
        End If
    Next
    shListe.Columns.AutoFit
    shListe.[C:D].Cut
    shListe.[M:M].Insert Shift:=xlToRight
    Application.CutCopyMode = False
    Set shDaten = Nothing
    Set shListe = Nothing
End Sub
Schönen Feierabend,
NoNet

AW: 2 kleine Korrekturen, hier der Code

27.09.2007 18:10:11

Thomas

Hallo NoNet,
das Proggi ist haargenau das was ich brauche. Freu freu...
Besten Dank für die schnelle und sehr kompetente Hilfe.
Vielen Dank
Thomas Leitner

Beliebteste Forumthreads (12 Monate)

Excel nach Inhalt per VBA umschreiben

Forumthread: Excel nach Inhalt per VBA umschreiben

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread