VBA Spalten mittels Schleife füllen

Moderator: ModerationP

VBA Spalten mittels Schleife füllen

Beitragvon elmarvo » 29. Mai 2018, 12:45

Hallo,

ich beziehe mich auf folgenden Thread:
http://www.office-loesung.de/p/viewtopic.php?f=166&t=767275

In dem o. g. Thread wurde mir sehr gut erklärt, wie ich die Split-Funktion anwende und die dadurch ermittelten Werte an anderer Stelle untereinander transponiere. Da ich an einer Stelle dann aber nicht weiter kam, hab ich mich doch dazu entschlossen eine Schleife zu verwenden (mit einem Array aus der Split-Funktion). Hier bin ich nun auf ein neues Problem gestoßen und möchte euch um Rat bitten:

Meine Arbeitsmappe besteht aus zwei Tabellenblättern (Gst und HBGSt).
In Gst befinden sich zwei Spalten. In der ersten Spalte stehen Namen, in der zweiten Ziffern.
Aus Gst sollen nun für jeden Mitarbeiter die Ziffern nach HBGst untereinander übertragen werden. Zusätzlich soll eine Schleife durchlaufen werden, wenn es sich bei den Ziffern um einen Ziffernblock (z. B. 101-501) handelt.

Momentan gelingt es mir, die Werte aus der Zelle B2 in Gst untereinander in die Spalte B2:Bx in HBGst zu übertragen.

Wie kann ich die Spalte so variabel verwenden, dass Excel - auf gut Deutsch gesagt - folgendes tut:
- wenn Werte in Gst B2 vorhanden, dann übertrage diese nach HBGst B2:Bx
- wenn Werte in Gst B3 vorhanden, dann übertrage diese nach HBGst C2:Cx
- wenn Werte in Gst B3 vorhanden, dann übertrage diese nach HBGst D2:Dx
usw.

Ich hoffe es ist einigermaßen verständlich, was ich will :razz: Die Datei habe ich beigefügt.

Hier ist der komplette Code: (edit:noch einmal überarbeitet. Zielbereich wird nun immer gelöscht, bevor er neu befüllt wird. In der Datei ist es noch nicht aktualisiert, kann von der Arbeit aus nicht hochladen )
Code: Alles auswählen
Sub ZiffernUebertragen()
    Dim strWerte As String, i As Integer, iItem As Integer, vItem As Variant, _
        iLetzteZeile As Integer, rngBereich As Range, rngZelle As Range, _
        arrZahlen() As String, rngClear As Range, iZeile As Integer, iSpalte As Integer, _
        rngWriteTo As Range, j As Integer
   
    Application.EnableEvents = False
   
    'letzte befüllte Zeile im Blatt finden
    iLetzteZeile = Worksheets("Gst").Range("B" & Sheets("Gst").Rows.Count).End(xlUp).Row
   
    'Letzte benutzte Zelle vom Hilfsblatt finden (http://www.ozgrid.com/VBA/ExcelRanges.htm)
    If WorksheetFunction.CountA(Cells) > 0 Then
       
        'Rückwärtssuche zeilenweise
        iZeile = Cells.Find(What:="*", After:=[A1], _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious).Row
        'Rückwärtssuche spaltenweise
        iSpalte = Cells.Find(What:="*", After:=[A1], _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious).Column
    End If
    Set rngClear = Worksheets("HBGst").Range(Cells(2, 2), Cells(iZeile, iSpalte))
   
    Debug.Print rngClear.Address
   
    'Einträge im Hilfsblatt löschen
    rngClear.ClearContents
   
    'Variable des Zielbereichs bestimmen
    Set rngWriteTo = Worksheets("HBGst").Cells(2, 2)
       
    Debug.Print rngWriteTo.Address
   
    'Array mit Werten füllen
    For i = 2 To iLetzteZeile
        strWerte = Worksheets("Gst").Range("B" & i).Value
        arrZahlen = Split(strWerte, " ")
        i = 1
        j = 1
       
    'Array auswerten
            For Each vItem In arrZahlen
                Select Case True
               
                    Case Len(vItem) = 3 'einzelne dreistellige Endziffer
                        i = i + 1
                        'Set rngBereich = .Range("B" & i)
                        'Wert in Hilfsblatt (HBGst) schreiben
                        'rngBereich.Value = vItem
                                           
                    Case Len(vItem) = 7 'Zahlenblock
                        iItem = Left(vItem, 3)
                        i = i + 1
                        'Set rngBereich = .Range("B" & i)
                        'Wert in Hilfsblatt (HBGst) schreiben
                        'rngBereich.Value = iItem
                       
                        'Wert solange erhöhen bis Endwert des Blocks erreicht ist
                        Do Until iItem = Right(vItem, 3)
                            i = i + 1
                            iItem = iItem + 100
                            Set rngBereich = .Range("B" & i)
                            'Wert in Hilfsblatt (HBGst) schreiben
                            rngBereich.Value = iItem
                        Loop
                       
                    Case Else
                    'Case Len(vItem) = 5 und Case Len(vItem) = 2 fehlen noch
                End Select
            Next
        End With
    Next
   
    'Sortieren
        Worksheets("HBGst").Columns("B:B").Sort key1:=Worksheets("HBGst").Range("B2"), _
            order1:=xlAscending, Header:=xlYes
           
    Application.EnableEvents = True
End Sub


Viele Grüße und vielen Dank
elmarvo
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
Zuletzt geändert von elmarvo am 29. Mai 2018, 21:04, insgesamt 2-mal geändert.
elmarvo
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 109
Registriert: 15. Nov 2013, 09:44
Wohnort: Bonn

Re: VBA Spalten mittels Schleife füllen

Beitragvon 1Matthias » 29. Mai 2018, 19:50

Moin!
Hier dein Code zurück. Habe ihn mal angepasst. Anbei noch ein paar Bermerkungen / Fragen:
- Wofür hast du das enableevents drin? Zumindest in der Datei springt dort ja kein Event an. Vermute mal du meintest die Bildschirmaktualisierung - habe ich mal noch ergänzt
- Du hast die Schleife schon angelegt. Dann manipuliere darin nicht die Zählvariable (hier: i). Das geht meist schief. Wenn du intern dann was zählen musst, nimm eine neue Variable. Damit kannst du dann auch die einzelnen Durchläufe besser abwickeln.
- DIe ganzen set im select case sind nicht notwendig. Du kannst direkt die Zellen ansprechen. Habe ich auch mal geändert. Wenn es noch mehr Daten sind, wäre auch noch möglich erst alles in ein Array/DAtenfeld zu schreiben und dieses abschließend einmal in das Blatt zu schreiben - wäre schneller.
- Wenn du in SChleifen alles durchgehst, versuche mit cells(zeile, spalte) zu arbeiten. Dein Range mit festem Buchstaben ist da etwas unflexibel.
- Das sortieren mit in die for Schleife nehmen. Dabei auch von den Buchstaben auf deinen Zählindex umstellen.
- deklarieren deine Zählvariablen besser als long. Damit kannst du mehr Zeilen überprüfen als Excel hat. Falls deine Mitarbeiter sonst anwachsen, könnte es einen Fehler geben (bei der Anzahl zwar unwahrscheinlich s.h. https://www.vba-tutorial.de/variablen/datentypen.htm aber sicher ist sicher. )
- Dein Code funktioniert so nur, wenn die REihenfolge in Spalte A vom ersten Blatt identisch mit der Reihenfolge in Zeile 1 vom anderen ist. Wenn sich das was ändert bzw. gemixt ist, solltest du im zweiten Blatt erst noch die richtige Spalte suchen.
mehr fällt mir grad nicht ein. :-)

Code: Alles auswählen
Option Explicit

Sub ZiffernUebertragen()
    Dim strWerte As String, i As Integer, iItem As Integer, vItem As Variant, _
        iLetzteZeile As Integer, rngBereich As Range, rngZelle As Range, _
        arrZahlen() As String, rngClear As Range, iZeile As Integer, iSpalte As Integer
Dim eintrag As Long

Application.ScreenUpdating = False

    Application.EnableEvents = False
   
    'letzte befüllte Zeile
    iLetzteZeile = Worksheets("Gst").Range("B" & Sheets("Gst").Rows.Count).End(xlUp).Row
   
    'bereits vorhandene Werte im Zielbereich löschen
    Worksheets("HBGst").Select
   
    'Letzte benutzte Zelle finden (http://www.ozgrid.com/VBA/ExcelRanges.htm)
    If WorksheetFunction.CountA(Cells) > 0 Then
       
        'Rückwärtssuche zeilenweise
        iZeile = Cells.Find(What:="*", After:=[A1], _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious).Row
        'Rückwärtssuche spaltenweise
        iSpalte = Cells.Find(What:="*", After:=[A1], _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious).Column
    End If
    Set rngClear = Range(Cells(2, 2), Cells(iZeile, iSpalte))
    rngClear.Select
    rngClear.ClearContents
   
    'von B2 bis zur letzten befüllten Zeile durchgehen und Werte zu Array hinzufügen
    For i = 2 To iLetzteZeile
        strWerte = Worksheets("Gst").Range("B" & i).Value
        arrZahlen = Split(strWerte, " ")
        eintrag = 2
        With Worksheets("HBGst")
            For Each vItem In arrZahlen
                Select Case True
               
                    Case Len(vItem) = 3 'einzelne dreistellige Endziffer
                       
                        .Cells(eintrag, i) = vItem
                        eintrag = eintrag + 1
                                           
                    Case Len(vItem) = 7 'Zahlenblock
                        iItem = Left(vItem, 3)

                        .Cells(eintrag, i) = iItem
                        eintrag = eintrag + 1
                       
                        'Wert solange erhöhen bis Endwert des Blocks erreicht ist
                        Do Until iItem = Right(vItem, 3)
                            iItem = iItem + 100
                            .Cells(eintrag, i) = iItem
                            eintrag = eintrag + 1

                        Loop
                       
                    Case Else
                    'Case Len(vItem) = 5 und Case Len(vItem) = 2 fehlen noch
                End Select
            Next
        End With
       
       
    'Sortieren
        Worksheets("HBGst").Columns(i).Sort key1:=Worksheets("HBGst").Cells(2, i), _
            order1:=xlAscending, Header:=xlYes
       
    Next

    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub


VG
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 483
Registriert: 15. Aug 2017, 18:36

Re: VBA Spalten mittels Schleife füllen

Beitragvon elmarvo » 29. Mai 2018, 20:58

Hey Matthias!

Vielen Dank für dein Feedback! Hier meins:

- enableevents hab ich eingebaut, weil er (gefühlt) die ganzen Zeilen durchgegangen ist und das Tabellenblatt aktiviert und ich einfach kein "smoothes" Gefühl hatte ^^

- die Möglichkeit mit Cells habe ich mir gerade angesehen :D hab auch bereits meinen Code dahingehend verändert. Der Code im Eingangsthread ist nun das, was ich bis jetzt habe :mrgreen: mal schauen, was mit deiner Hilfe daraus wird. 8-)

- dass das schneller geht hätte ich nicht gedacht. Guter Tipp!

- ja, dass Range unflexibel ist, habe ich mittlerweile auch gemerkt.. s.o. ^^ aber gut, dass du es erwähnst :)

- okay, dass man während der Schleife bereits sortieren kann, das habe ich nicht bedacht, cool! :)

- ich hab mir bereits gedacht, dass jemand mich auf die Deklaration als Integer aufmerksam macht ^^ ich gehe halt wirklich nicht von mehr als 1000 Einträgen aus. Aber sicher ist sicher - stimmt schon. Und heutzutage ist Speicher ja auch nicht mehr so das Problem ^^

Vielen Dank an der Stelle auf jeden Fall nochmal! Ich werd mich morgen ransetzen und deinen Code studieren :) und dann schreib ich nochmal was daraus geworden ist :)

Viele Grüße
elmarvo
elmarvo
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 109
Registriert: 15. Nov 2013, 09:44
Wohnort: Bonn

Re: VBA Spalten mittels Schleife füllen

Beitragvon elmarvo » 10. Jun 2018, 21:59

Hallo Matthias,
hallo Community!

Ich hab es nun endlich hinbekommen. Ist zwar ein wenig träge und bestimmt noch optimierungsbedürftig, aber es tut, was es soll.

Es erkennt nun einzelne zweistellige Zahlen, zweistellige Zahlenblöcke (z.B. 01-31 ==> 001, 101, 201, 301, 401, 501, 601, 701, 801, 901, 011, 111, 211, 311, 411, 511, 611, 711, 811, 911, 021, 121, usw.), einzelne dreistellige Zahlen und dreistellige Zahlenblöcke (z. B. 005-305 ==> 005, 105, 205, 305). Als Trennzeichen für den Split dient hier " / ".


Code: Alles auswählen
Option Explicit
Sub ZiffernUebertragen()
   
' Bildschirmaktualisierung deaktivieren
Application.ScreenUpdating = False
   
'Bereits vorhandene Werte in "BlattB" löschen
'(http://www.ozgrid.com/VBA/ExcelRanges.htm)
Dim LoeschZeile As Long, LoeschSpalte As Long
Dim BereichLoeschen As Range
Worksheets("BlattB").Select

If WorksheetFunction.CountA(Cells) > 0 Then
       
    'Rückwärtssuche zeilenweise
    LoeschZeile = Cells.Find(What:="*", After:=[A1], _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
    'Rückwärtssuche spaltenweise
    LoeschSpalte = Cells.Find(What:="*", After:=[A1], _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious).Column
End If

Set BereichLoeschen = Worksheets("BlattB").Range(Cells(2, 2), Cells(LoeschZeile, LoeschSpalte))
BereichLoeschen.ClearContents

'Neue Werte in "BlattA" erfassen und in "BlattB" einfügen

Dim LetzteEingabeA As Long, LetzteEingabeBSB As Long, LetzteEingabeSB As Long
Dim QuellenZelle As Range, ZielZelle As Range
Dim Spalte As Long, Zeile As Long
Dim ZweiBlockItem As Long, DreiBlockItem As Long, ArrItem As Variant, i As Long, j As Long
Dim ArrZahlen() As String, ZweiBlockAnfang As Long, ZweiBlockEnde As Long
   
'Wenn er ein Sheet nicht findet, soll er überspringen
On Error Resume Next
    LetzteEingabeA = Worksheets("BlattA").Range("B" & Sheets("BlattA").Rows.Count).End(xlUp).Row
    LetzteEingabeBSB = Worksheets("C").Range("B" & Sheets("BlattA").Rows.Count).End(xlUp).Row
    LetzteEingabeSB = Worksheets("E").Range("B" & Sheets("BlattA").Rows.Count).End(xlUp).Row
On Error GoTo 0
   
'Inhalte auslesen und je nach Eigenschaft übertragen
For Spalte = 2 To LetzteEingabeA
    BlattA.Activate
        Range(Cells(Spalte, 2), Cells(Spalte, 2)).Select
        ArrZahlen = Split(Selection, " / ")
        Zeile = 2
    BlattB.Activate
       
    For Each ArrItem In ArrZahlen
           
        'Einzelne zweistellige Endziffer
        If Len(ArrItem) = 2 Then
            Cells(Zeile, Spalte) = ArrItem
            Zeile = Zeile + 1
            For i = 1 To 9
                ArrItem = ArrItem + 100
                Cells(Zeile, Spalte) = ArrItem
                Zeile = Zeile + 1
            Next
           
        'einzelne dreistellige Endziffer
        ElseIf Len(ArrItem) = 3 Then
            Cells(Zeile, Spalte) = ArrItem
            Zeile = Zeile + 1
                   
        'Zahlenblock von/bis zweistellig
        ElseIf Len(ArrItem) = 5 Then
                ZweiBlockAnfang = Left(ArrItem, 2)
                ZweiBlockEnde = Right(ArrItem, 2)
                   
                For i = ZweiBlockAnfang To ZweiBlockEnde Step 10
                    ZweiBlockItem = i
                    Cells(Zeile, Spalte) = ZweiBlockItem
                    Zeile = Zeile + 1
                    For j = 1 To 9
                        ZweiBlockItem = ZweiBlockItem + 100
                        Cells(Zeile, Spalte) = ZweiBlockItem
                        Zeile = Zeile + 1
                    Next
                Next
        'Zahlenblock von/bis dreistellig
        ElseIf Len(ArrItem) = 7 Then
            DreiBlockItem = Left(ArrItem, 3)
            Cells(Zeile, Spalte) = DreiBlockItem
            Zeile = Zeile + 1
                   
            'Wert solange erhöhen bis Endwert des Blocks erreicht ist
            Do Until DreiBlockItem = Right(ArrItem, 3)
                DreiBlockItem = DreiBlockItem + 100
                Cells(Zeile, Spalte) = DreiBlockItem
                Zeile = Zeile + 1
            Loop
        End If
    Next
'Sortieren
Worksheets("BlattB").Columns(Spalte).Sort key1:=Worksheets("BlattB").Cells(Zeile, Spalte), _
    order1:=xlAscending, Header:=xlYes
Next
BlattA.Activate
MsgBox "Datenübertragung beendet."

' Bildschirmaktualisierung reaktivieren
Application.ScreenUpdating = True
End Sub



Falls jemand einen alternativen Weg kennt, der ein wenig fixer ist, dann gerne her damit :D

Ansonsten verleibe ich mit bestem Dank und vielen Grüßen
elmarvo
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
elmarvo
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 109
Registriert: 15. Nov 2013, 09:44
Wohnort: Bonn

Re: VBA Spalten mittels Schleife füllen

Beitragvon 1Matthias » 12. Jun 2018, 19:24

Moin!
Also habe die Datei mal getestet. Mit deinem Datensatz hier ist sie aber nicht so langsam. Wenn du noch Zeit einsparen willst, lasse die select und activate weg.
Dann solltest du die Löschzeile mit in die if schleife am Anfang ziehen. Falls nämlich WorksheetFunction.CountA(Cells) = 0 gilt, wird dein Zeilen / Spaltenindex nicht gesetzt und die Löschzeile schlägt fehlt.
Um den Code mal noch genaue zu untersuchen, solltest du mal die Logik hinter
z.B. 01-31 ==> 001, 101, 201, 301, 401, 501, 601, 701, 801, 901, 011, 111, 211, 311, 411, 511, 611, 711, 811, 911, 021, 121, usw.
kurz erläutern. Wieso wird der zweistellige Zahlenblock auf einmal dreistellig. ich hätte gedacht, dass wird 01, 11, 21, 31. So wie du es auch bei den dreistelligen gezeigt hast.
Wenn du sonst noch Zeit einsparen willst, schätze die maximale Zeileneinträge in Blatt B ab und erstelle ein Array. In das schreibst du deine WErte und überträgst dass dann ganz am Ende. Damit hast du dann nur einen Schreibvorgang und schreibst nicht jeden Wert einzeln in das Blatt.
VG
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 483
Registriert: 15. Aug 2017, 18:36

Re: VBA Spalten mittels Schleife füllen

Beitragvon elmarvo » 13. Jun 2018, 20:47

Hey Matthias!

Bei uns wird der zuständige Mitarbeiter anhand der letzten drei Ziffern des Aktenzeichens festgelegt. Es sind also demnach insgesamt 1000 Ziffern, die zur Verfügung stehen - 000 mit eingerechnet. Um genau zu sein: 000 - 999.

Die Ziffern werden entweder

- einzeln (z. B. 123)

- als dreistelliger Zahlenblock (z.B. 023-923, was dann 023, 123, 223, 323, 423, 523, 623, 723, 823 und 923 ausgeschrieben ergibt) oder

- verkürzt als zweistelliger Zahlenblock verteilt (z. B. 01-91 ergibt dann die dreistelligen Zahlenblöcke 001-901, 011-911, 021-921, 031-931, 041-941, 051-951, 061-961, 071-971, 081-981 und 091-991)

Ich hoffe das ist nun etwas verständlicher.

Die selects und activates hatte ich gesetzt, da Excel - warum auch immer - nicht die Werte aus dem richtigen Worksheet gezogen hat, auch wenn ich dies innerhalb einer With ... End With Anweisung durchgeführt habe. Ich sehe aber ein, dass das nicht sehr professionell ist die Worksheets zu aktivieren und auszuwählen (hat den Charme eines Makrorekorders ^^).

Das mit der if Abfrage am Anfang hört sich sinnvoll an.

Mit einem Array war mein ursprünglicher Ansatz. Allerdings kam ich da irgendwann nicht mehr weiter, habe es mit einer collection versucht und bin letztendlich dabei gelandet, es sein zu lassen :oops: bin mit Arrays noch nicht zu 100 % vertraut.

Viele Grüße
elmarvo
elmarvo
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 109
Registriert: 15. Nov 2013, 09:44
Wohnort: Bonn

Re: VBA Spalten mittels Schleife füllen

Beitragvon 1Matthias » 14. Jun 2018, 19:11

Moin!
Habe mal schnell zwei Arrays in deinen Code eingebaut. Das eine ist für die Ausgangsdaten, das zweite für die Ergebnisse. Die Sortierung musste dafür aber in eine extra Schleife. Nun hast du einen Lesevorgang und einen Schreibvorgang. Sollte damit schneller laufen. Das mit den Zahlen habe ich nicht verändert - sah so auf die schnelle gut aus.
Die Löschung habe ich auch mal in das if then gebastelt.
Müsstet nach diesem Schema lediglich noch den Code für Blatt C und E erweitern.
Evtl. musst du den Code mal zu dir übernehmen. Habe Ex03 und habe vorher die xlsm mit OO nach xls konvertiert. Damit hat er ein paar Tabellenblattleichen gebastelt.

VG
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 483
Registriert: 15. Aug 2017, 18:36

Re: VBA Spalten mittels Schleife füllen

Beitragvon elmarvo » 14. Jun 2018, 20:30

Hey Matthias,

ich kann die Datei auf dem Tablet leider nicht testen mangels Makromöglichkeiten.. werde sie mir morgen früh aber genauer anschauen (und mir abgucken wie deine zwei Arrays aufgebaut sind ;) )

Auf jeden Fall schonmal vielen vielen Dank, dass du dir die Mühe gemacht hast. Ich rechne das hier wirklich jedem hoch an. Generell ist dieses Forum zu meiner liebsten Anlaufstelle bei Excelproblemen geworden :) top!

Sollte ich noch Fragen zu deinem Code haben melde ich mich nochmal. Ansonsten verbleibe ich mit

vielen Grüßen
elmarvo
elmarvo
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 109
Registriert: 15. Nov 2013, 09:44
Wohnort: Bonn

Re: VBA Spalten mittels Schleife füllen

Beitragvon elmarvo » 20. Jun 2018, 09:57

1Matthias hat geschrieben:Moin!
Habe mal schnell zwei Arrays in deinen Code eingebaut. Das eine ist für die Ausgangsdaten, das zweite für die Ergebnisse. [...]


Hey Matthias!

Ich habe den Code mal ein wenig ordentlicher und besser lesbar gestaltet. Zu deinen Arrays habe ich noch eine Frage.

Zunächst der Code:
Code: Alles auswählen
Option Explicit

Sub ZiffernUebertragen()

    Dim LoeschZeile As Long, LoeschSpalte As Long, LoeschBereich As Range
    Dim LetzteEingabeGst As Long, LetzteEingabeBSB As Long, LetzteEingabeSB As Long
    Dim Spalte As Long, Zeile As Long, i As Long, j As Long
    Dim ZweiBlockItem As Long, DreiBlockItem As Long, ZweiBlockAnfang As Long, ZweiBlockEnde As Long
    Dim ArrItem As Variant, ArrZahlen() As String
    Dim ArrQuelle() As Variant, ArrErgebnis() As Variant

    'Bildschirmaktualisierung deaktivieren
    Application.ScreenUpdating = False

    'Bereits vorhandene Werte in Gst_Daten löschen
    With ws_Gst_Daten
        If WorksheetFunction.CountA(Cells) > 0 Then
            LoeschZeile = Cells.Find(What:="*", After:=[A1], _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            LoeschSpalte = Cells.Find(What:="*", After:=[A1], _
                        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
            Set LoeschBereich = Range(Cells(2, 2), Cells(LoeschZeile, LoeschSpalte))
            LoeschBereich.ClearContents
        End If
    End With

    'Werte erfassen
    With ws_Gst
        LetzteEingabeGst = .Range("B" & .Rows.Count).End(xlUp).Row
        ArrQuelle = .UsedRange
    End With

    ReDim ArrErgebnis(1 To 1000, 1 To LetzteEingabeGst - 1)
   
    For Spalte = 2 To LetzteEingabeGst
        ArrZahlen = Split(ArrQuelle(Spalte, 2), " / ")
        Zeile = 1
       
        For Each ArrItem In ArrZahlen
       
            Select Case True
                'Einzelne zweistellige Endziffer
                Case Len(ArrItem) = 2
                    ArrErgebnis(Zeile, Spalte - 1) = ArrItem
                    Zeile = Zeile + 1
               
                    For i = 1 To 9
                        ArrItem = ArrItem + 100
                        ArrErgebnis(Zeile, Spalte - 1) = ArrItem
                        Zeile = Zeile + 1
                    Next i
           
                'Einzelne dreistellige Endziffer
                Case Len(ArrItem) = 3
                    ArrErgebnis(Zeile, Spalte - 1) = ArrItem
                    Zeile = Zeile + 1
           
                'Zahlenblock zweistellig
                Case Len(ArrItem) = 5
                    ZweiBlockAnfang = Left(ArrItem, 2)
                    ZweiBlockEnde = Right(ArrItem, 2)
                   
                    For i = ZweiBlockAnfang To ZweiBlockEnde Step 10
                        ZweiBlockItem = i
                        ArrErgebnis(Zeile, Spalte - 1) = ZweiBlockItem
                        Zeile = Zeile + 1
                       
                        For j = 1 To 9
                            ZweiBlockItem = ZweiBlockItem + 100
                            ArrErgebnis(Zeile, Spalte - 1) = ZweiBlockItem
                            Zeile = Zeile + 1
                        Next j
                    Next i
               
                'Zahlenblock dreistellig
                Case Len(ArrItem) = 7
                    DreiBlockItem = Left(ArrItem, 3)
                    ArrErgebnis(Zeile, Spalte - 1) = DreiBlockItem
                    Zeile = Zeile + 1
                   
                    Do Until DreiBlockItem = Right(ArrItem, 3)
                        DreiBlockItem = DreiBlockItem + 100
                        ArrErgebnis(Zeile, Spalte - 1) = DreiBlockItem
                        Zeile = Zeile + 1
                    Loop
           
            End Select
        Next
    Next
   
    'Übertragen und Sortieren der Werte
    With ws_Gst_Daten
        .Range(.Cells(2, 2), .Cells(1000, LetzteEingabeGst)) = ArrErgebnis
        For Spalte = 2 To LetzteEingabeGst
            .Columns(Spalte).Sort key1:=.Cells(2, Spalte), order1:=xlAscending, Header:=xlYes
        Next
    End With
   
    MsgBox "Daten wurden übertragen."
   
    'Bildschirmaktualisierung reaktivieren
    Application.ScreenUpdating = True
   
End Sub


Nun meine Frage: Das Array ArrErgebnis wird am Ende immer mit - 1 dimensioniert. Warum ist das so? Wird dadurch nicht das Ende abgeschnitten, da man immer einen Schritt vor das Ende geht? Falls das bei Arrays grundsätzlich so ist und Du einen Link zu einer Erklärung dazu hast, dann poste ihn gerne hier, damit ich mich da reinarbeiten kann :)

Viele Grüße
elmarvo
elmarvo
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 109
Registriert: 15. Nov 2013, 09:44
Wohnort: Bonn

Re: VBA Spalten mittels Schleife füllen

Beitragvon snb » 20. Jun 2018, 11:07

Oder:

Code: Alles auswählen
Sub M_snb()
   sn = Tabelle1.Cells(1).CurrentRegion

   For j = 2 To UBound(sn)
      If sn(j, 2) <> "" Then
          c00 = ""
         sp = Split(sn(j, 2), " / ")
         For jj = 0 To UBound(sp)
            If InStr(sp(jj), "-") Then sp(jj) = Join(Evaluate("transpose(row(" & Replace(sp(jj), "-", ":") & "))"), "|")
            c00 = c00 & "|" & sp(jj)
        Next
        st = Split(Mid(c00, 2), "|")
        Tabelle2.Cells(2, j).Resize(UBound(st)) = Application.Transpose(st)
      End If
   Next
End Sub
Zuletzt geändert von snb am 20. Jun 2018, 12:48, insgesamt 1-mal geändert.
snb
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 6041
Registriert: 25. Sep 2014, 16:37

Re: VBA Spalten mittels Schleife füllen

Beitragvon elmarvo » 20. Jun 2018, 12:02

Hey snb,

wow! Das ist mal kurz und knapp zusammengefasster Code... leider doch etwas kryptisch für den Laien :oops:

Habe deinen Code angepasst und getestet und er liefert mir ab einem Punkt eine Fehlermeldung, dass die Typen unverträglich seien.
Meine Sheets heißen ws_Gst und ws_Gst_Daten

Code: Alles auswählen
Sub M_snb()
    Dim sn
    Dim j As Long
    Dim jj As Long
    Dim sp, st, c00

   sn = ws_Gst.Cells(1).CurrentRegion

   For j = 2 To UBound(sn)
      If sn(j, 2) <> "" Then
          c00 = ""
         sp = Split(sn(j, 2), " / ")
         For jj = 0 To UBound(sp)
            If InStr(sp(jj), "-") Then sp(jj) = Join(Evaluate("transpose(row(" & Replace(sp(jj), "-", ":") & "))"), "|")
            c00 = c00 & "|" & sp(jj)
        Next
        st = Split(Mid(c00, 2), "|")
        ws_Gst_Daten.Cells(2, j).Resize(UBound(st)) = Application.Transpose(st)
      End If
   Next
End Sub


Hab ich die Variablen hier falsch deklariert? Was genau ist "sn" in diesem Fall? Ich dachte zunächst es sei eine Range, aber dafür fehlt anschließend die Set-Anweisung. Bin echt verwirrt ^^

Kann mir jemand bzgl. der Frage zu dem Array und der Dimensionierung - 1 etwas sagen? :oops: Ich möchte das echt gerne verstehen..

Viele Grüße
elmarvo
elmarvo
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 109
Registriert: 15. Nov 2013, 09:44
Wohnort: Bonn

Re: VBA Spalten mittels Schleife füllen

Beitragvon snb » 20. Jun 2018, 12:47

Viele Antworten:

http://www.snb-vba.eu/VBA_Arrays_en.html

Verzichte auf Deklarationen.

Die Codenames sind doch 'Tabelle1' und 'Tabelle2' wie in der gepostete Datei.
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
snb
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 6041
Registriert: 25. Sep 2014, 16:37

Re: VBA Spalten mittels Schleife füllen

Beitragvon elmarvo » 20. Jun 2018, 13:02

Hallo snb,

danke für den Link!

Ja, die Codenames waren Tabelle1 und Tabelle2. Hatte sie zwischenzeitig geändert. Aber selbst wenn ich die Codenames Tabelle1 und Tabelle2 verwende erhalte ich diese Fehlermeldung in der Zeile:

Code: Alles auswählen
sp(jj) = Join(Evaluate("transpose(row(" & Replace(sp(jj), "-", ":") & "))"), "|")


Verzichte auf Deklarationen

Meckert Excel dann nicht aufgrund des Option Explicits?

Vielleicht lassen sich meine Fragen ja bereits durch deinen Link beantworten ^^ Ich melde mich ggf. später nochmal.

Edit: wow! Deine (?) Homepage erklärt ja wirklich sehr ausführlich. Danke!

Viele Grüße
elmarvo
elmarvo
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 109
Registriert: 15. Nov 2013, 09:44
Wohnort: Bonn

Re: VBA Spalten mittels Schleife füllen

Beitragvon snb » 20. Jun 2018, 14:52

Darum: lösche 'Option Explicit'.

Ich kenne deine Datei nicht.
In der Datei die du hochgeladet hast funktioniert es jedenfalls.
Zuletzt geändert von snb am 20. Jun 2018, 15:21, insgesamt 1-mal geändert.
snb
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 6041
Registriert: 25. Sep 2014, 16:37

Re: VBA Spalten mittels Schleife füllen

Beitragvon DerHoepp » 20. Jun 2018, 15:02

Gegenempfehlung:
Darum: lösche 'Option Explicit'.

Mach das erst, wenn du weißt, was du tust.
DerHoepp
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 7003
Registriert: 14. Mai 2013, 11:08

Nächste

Zurück zu Excel Forum (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 15 Gäste

cron