Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
492to496
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
492to496
492to496
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Makro benötigt

Makro benötigt
04.10.2004 15:21:33
Christian
Hallo,
ich benötige ein Makro, dass folgendes macht:
Pro Semikolon in Spalte in A, soll eine neue Zeile eingefügt werden und die Werte, die von den Semikola getrennt wurden in diese Zeilen eingefügt werden. Und in Spalte B soll jeweils das Ganze stehen, was auch jetzt in Spalte B steht. Ist das möglich? Wenn ja, wie?
Vielen dank für Eure Hilfe.
Beispiel:
Ich habe z.B.:
Spalte A Spalte B
a;b;c xy;zy
und das Makro soll das zu
a xy;zy
b xy;zy
c xy;zy
machen.

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro benötigt
04.10.2004 16:50:54
Peter
Hallo Christian,
da du nicht geschrieben hast WO eingefügt werden soll, habe ich die Daten am Ende der vorhandenen angefügt.
Hier mein Makro
Gruß Peter


Option Explicit
Sub Einfügen_trennen()
Dim lZeilen      As Long        ' Anzahl Zeilen zu Beginn
Dim lIndx        As Long        ' For/Next Index Zeilen
Dim lZeile_neu   As Long        ' einzufügende Zeile
Dim iZeichen     As Integer     ' For/Next Index Zeichen
    
   lZeilen = Range("A65536").End(xlUp).Row
   lZeile_neu = lZeilen
   For lIndx = 1 To lZeilen
      Cells(lZeilen, 1).Value = Trim(Cells(lZeilen, 1).Value)
      If InStr(Cells(lZeilen, 1).Value, ";") > 0 Then
         lZeile_neu = lZeile_neu + 1
         For iZeichen = 1 To Len(Cells(lIndx, 1).Value)
            If Mid(Cells(lIndx, 1).Value, iZeichen, 1) <> ";" Then
               Cells(lZeile_neu, 1).Value = Cells(lZeile_neu, 1).Value & _
                   Mid(Cells(lIndx, 1).Value, iZeichen, 1)
             Else
               Cells(lZeile_neu, 2).Value = Cells(lIndx, 2).Value
               lZeile_neu = lZeile_neu + 1
            End If
         Next iZeichen
         Cells(lZeile_neu, 2).Value = Cells(lIndx, 2).Value
      End If
   Next lIndx
End Sub


Anzeige
AW: eine kleine Korrektur
04.10.2004 21:46:03
Peter
Hallo Christian,
hier kommen zwei Versionen.
die erste hängt die gesplitteten Zeilen hinten an die Tabellendaten an,
die zweite Version fügt die gesplitteten hinter die jeweilige Zeile.
Gruß, Peter


Sub Einfügen_trennen()
Dim lZeilen      As Long                    ' Anzahl Zeilen zu Beginn
Dim lIndx        As Long                    ' For/Next Index Zeilen
Dim lZeile_neu   As Long                    ' einzufügende Zeile
Dim iZeichen     As Integer                 ' For/Next Index Zeichen
    
   lZeilen = Range("A65536").End(xlUp).Row  ' Anzahl Zeilen zu Beginn
   lZeile_neu = lZeilen                     ' Anzahl Zeilen speichern
   For lIndx = 1 To lZeilen                 ' von Zeile 1 bis Ende
                                            
                                            ' gibt es Semikola ?
      If InStr(Cells(lIndx, 1).Value, ";") > 0 Then
                                            ' eventuelle Leerzeichen entfernen
         Cells(lIndx, 1).Value = Trim(Cells(lIndx, 1).Value)
         lZeile_neu = lZeile_neu + 1        ' neue Zeile + 1
                                            ' Zelle zeichenweise abarbeiten
         For iZeichen = 1 To Len(Cells(lIndx, 1).Value)
                                            ' Zeichen ungleich ";" übernehmen
            If Mid(Cells(lIndx, 1).Value, iZeichen, 1) <> ";" Then
               Cells(lZeile_neu, 1).Value = Cells(lZeile_neu, 1).Value & _
                   Mid(Cells(lIndx, 1).Value, iZeichen, 1)
             Else
                                            ' Zelle Spalte B übergeben
               Cells(lZeile_neu, 2).Value = Cells(lIndx, 2).Value
                                            ' neue Zeile + 1
               lZeile_neu = lZeile_neu + 1
            End If
         Next iZeichen                      ' nächstes Zeichen in der Zelle
                                            ' letzte Zelle Spalte B übergeben
         Cells(lZeile_neu, 2).Value = Cells(lIndx, 2).Value
      End If
   Next lIndx                               ' nächste zu verarbeitende Zeile
End Sub
'   oder direkt hinter der Zeile die Einfügungen machen
Sub Zeilen_direkt()
Dim lLetzteC     As Long                    ' letzte belegte Zelle/Zeile
Dim lZeile       As Long                    ' For/Next Index Zeile
Dim lZeilenNr    As Long                    ' Einfüge-Zeilen Nummer
Dim iZeichen     As Integer                 ' For/Next Index Zeichen
   lLetzteC = Range("A65536").End(xlUp).Row ' Anzahl Zeilen zu Beginn
   For lZeile = lLetzteC To Step -1       ' die Tabelle rückwärts abarbeiten
                                            ' gibt es Semikola ?
      If InStr(Cells(lZeile, 1).Value, ";") > 0 Then
         lZeilenNr = lZeile + 1             ' Einfüge-Zeile ermitteln
                                            ' eine Zeile einfügen
         Rows(lZeilenNr).Insert shift:=xlDown
                                            ' eventuelle Leerzeichen entfernen
         Cells(lZeile, 1).Value = Trim(Cells(lZeile, 1).Value)
                                            ' Zelle zeichenweise abarbeiten
         For iZeichen = 1 To Len(Cells(lZeile, 1).Value)
                                            ' Zeichen ungleich ";" übernehmen
            If Mid(Cells(lZeile, 1).Value, iZeichen, 1) <> ";" Then
               Cells(lZeilenNr, 1).Value = Cells(lZeilenNr, 1).Value & _
                  Mid(Cells(lZeile, 1).Value, iZeichen, 1)
             Else
                                            ' Zelle Spalte B übergeben
               Cells(lZeilenNr, 2).Value = Cells(lZeile, 2).Value
               lZeilenNr = lZeilenNr + 1    ' Einfüge-Zeile ermitteln
                                            ' eine Zeile einfügen
               Rows(lZeilenNr).Insert shift:=xlDown
            End If
         Next iZeichen                      ' nächstes Zeichen in der Zelle
                                            ' Zelle Spalte B übergeben
         Cells(lZeilenNr, 2).Value = Cells(lZeile, 2).Value
      End If
   Next lZeile                              ' vorige zu verarbeitende Zeile
End Sub


Anzeige
AW: Makro benötigt
Reinhard
Hi Christian,
Sub tt()
Dim teile() As String
For pos = Range("A65536").End(xlUp).Row To 1 Step -1 ' die 1 anpassen, falls Überschrift usw.
teile = Split(Cells(pos, 1), ";")
For z = 0 To UBound(teile)
If z > 0 Then Cells(pos + z, 1).EntireRow.Insert
Range(Cells(pos + z, 1), Cells(pos + z, 1)) = teile(z)
Next z
Range(Cells(pos, 2), Cells(pos + UBound(teile), 2)) = Cells(pos, 2)
Next pos
End Sub

Gruß
Reinhard
AW: Makro benötigt
Christian
Da habe ich das Problem: Variable nicht definiert (pos) ich hab's mit Range und String probiert, aber die funktionieren nicht.
Gruß,
christian
Anzeige
AW: Makro benötigt
Christian
Habe es selber hinbekommen!
AW: Makro benötigt
Christian
Vielen, vielen Dank für Ihre Hilfe.
Ich werds gleich ausprobieren und hoffe es funktioniert.
Danke!!!
AW: Makro benötigt
Christian
Hallo,
ich habe das Sub Zielen_direkt von Peter Feustel genommen. Vielen Dank nochmal.
Es funktioniert auch wunderbar. Nur gibt es noch ein kleines Detail...
Er fügt zwar alles genauso an, wie ich es wollte, er muss aber noch die ursprüngliche Zeile heraus löschen. Kannst du mir noch sagen was und wo ich es in den Code einfügen muss. Vielen Dank
Ich darf nochmal sagen, mit den ganzen Kommentaren am Zeilenende ist alles selbst für Anfänger gut verständlich! Prima erklärt!!!
Christian
Anzeige
AW: Makro benötigt
05.10.2004 09:28:20
Peter
Hallo Christian,
wenn du die alten Zeilen nicht mehr benötigst, nimm die Lösung (das Makro) von Reinhard.
Gruß, Peter

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige