Thema Datum  Von Nutzer Rating
Antwort
23.01.2018 22:15:19 Nixontira
NotSolved
Blau Zeichen aus Zelle in mehrere spalten ausgeben
24.01.2018 00:36:21 Gast21396
NotSolved
24.01.2018 09:12:04 Nixontira
NotSolved
24.01.2018 10:27:58 Nixontira
NotSolved

Ansicht des Beitrags:
Von:
Gast21396
Datum:
24.01.2018 00:36:21
Views:
579
Rating: Antwort:
  Ja
Thema:
Zeichen aus Zelle in mehrere spalten ausgeben

Da gibt es unzählige, denkbare Möglichkeiten.

Hier mal eine die die Excel-Funktion TextInSpalten nutzt.

Option Explicit

Sub Example01()
  
  Dim rngCell As Excel.Range
  Dim blnErr As Boolean
  Dim n As Long
  
  'um diese Zelle geht's
  Set rngCell = Worksheets("Tabelle1").Range("B3")
  
  On Error GoTo Final
  With rngCell
    'reduziere den Zelleninhalt auf den Teil zwischen 'c' und '-'
    .Value = Mid$(.Value, InStr(.Value, "c") + 1, InStr(.Value, "-") - InStr(.Value, "c") - 1)
    'verw. Excel-Funktion: Daten -> TextInSpalten
    Call .TextToColumns(rngCell, xlDelimited, Other:=True, OtherChar:="+")
  End With
  On Error GoTo 0 'Fehlerunterdrückung: AUS
  
  'im folgenden wird solange Zelle um Zelle weiter nach rechts gesprungen
  'bis jene Zelle keinen Inhalt mehr hat, dabei wird ggf. der Faktor vor '*' behandelt
  Do
    'schaue ob Zelle ein '*' beinhaltet
    n = InStr(1, rngCell.Value, "*")
    
    'als nächstes wird ggf. der Zelleninhalt zerlegt
    'Inhalt Bsp: 3*0,5 wird zu: [n:=3] * [Ausdruck:=0,5]
    'entsprechend zu n werden zustäzliche Zellen eingefügt und mit Ausdruck belegt
    '(andere Daten werden dabei nach rechts verschoben)
    
    If n > 0 Then
      On Error Resume Next 'Fehlerunterdrückung: AN
      n = Left(rngCell.Value, n - 1)
      If Err.Number <> 0 Then
        On Error GoTo 0 'Fehlerunterdrückung: AUS
        blnErr = True
        n = 1
      ElseIf n > 1 Then
        'Zelleninhalt um den Ausdruck 'n*' kürzen
        rngCell.Value = Mid(rngCell.Value, InStr(1, rngCell.Value, "*") + 1)
        rngCell.Value = rngCell.Value * 1 'versuche Zelleninhalt als Zahl zu formatieren
        On Error GoTo 0 'Fehlerunterdrückung: AUS
        'füge zusätzlichen Zellen ein
        Call rngCell.Resize(, n - 1).Offset(, 1).Insert(xlShiftToRight)
        rngCell.Resize(, n).Value = rngCell.Value 'kopiere Inhalt auf Zellen
      End If
    Else
      n = 1
    End If
    
    'springe n Zellen nach rechts (damit werden die ggf. eingefügten Zellen mit übersprungen)
    Set rngCell = rngCell.Offset(, n)
    
  Loop While Trim$(rngCell.Value) <> ""
  
Final:
  If Not blnErr Then
    Call MsgBox("Vorgang abgeschlossen.", vbInformation)
  Else
    Call MsgBox("Vorgang mit Fehler(n) abgeschlossen." & vbNewLine & _
                "Überprüfen sie das Ergebnis!", vbExclamation)
  End If
  
End Sub

Grüße


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
23.01.2018 22:15:19 Nixontira
NotSolved
Blau Zeichen aus Zelle in mehrere spalten ausgeben
24.01.2018 00:36:21 Gast21396
NotSolved
24.01.2018 09:12:04 Nixontira
NotSolved
24.01.2018 10:27:58 Nixontira
NotSolved