Untertitel aus Textdateien in gewünschtes Excelformat bringen

[SonjaFido]

Hallo liebe Leute,

ich möchte gerne Textdateien von Untertiteln in ein entsprechendes Excelformat bringen.
Die Untertitel in der Textdatei sind dabei nach folgendem Format aufgebaut:

1. Indexnummer ( normale Zahl)
2. Zeitmarke
3. Untertiteltext, manchmal über verschiednen Zeilen verteilt.

Das Ganze sieht in der Praxis dann so aus:

(Beispiel):

1
00:01:04,942 --> 00:01:07,711
GANGSTER: So there's a
nigger, a kike and a wop

2
00:01:07,712 --> 00:01:11,515
and they get surrounded by
Indians. The chief walks to them.

3
00:01:11,516 --> 00:01:13,283
He says, "Listen,
we're gonna kill you,

Mittels VBA möchte ich, dass die Textdatei in Excel danach so aussieht:
Indexnummer, Zeitmarke und Untertiteltext jeweils in einer Zelle.

1 00:01:04,942 --> 00:01:07,711 GANGSTER: So there's a nigger, a kike and a wop
2 00:01:07,712 --> 00:01:11,515 and they get surrounded by Indians. The chief walks to them.
3 00:01:11,516 --> 00:01:13,283 He says, "Listen, we're gonna kill you,

Mein funktionierender Code sieht dazu wie folgt aus:

Code:

Sub Untertitelumwandlung()

vbBereich = "A1:A" & Cells(Rows.Count, 1).End(xlUp).Row
Range(vbBereich).Select

For Each zelle In Selection
    'Eventuelle Formeln löschen:
    zelle.Replace What:="=- ", Replacement:=" "
    zelle.Replace What:="- ", Replacement:=" "
    zelle.Replace What:="=", Replacement:=" "
    
    If IsNumeric(zelle.Value) And InStr(zelle.Offset(1, 0), "-->") > 0 Then  
    zelle.Value = zelle.Value & "  " & zelle.Offset(1, 0).Value & "  "
    zelle.Offset(1, 0).Value = ""
    End If
Next zelle



vbBereich = "A1:A" & Cells(Rows.Count, 1).End(xlUp).Row
Range(vbBereich).Select

For Each zelle In Selection
  If Not InStr(zelle.Offset(1, 0), "-->") > 0 And InStr(zelle.Offset(0, 0), "-->") > 0 Then
    tmp = zelle.Offset(1, 0).Value
    zelle.Offset(1, 0).Value = zelle.Value & " " & tmp
    zelle.Value = ""
    End If
Next zelle

vbBereich = "A1:A" & Cells(Rows.Count, 1).End(xlUp).Row
Range(vbBereich).SpecialCells(xlCellTypeBlanks).Delete
End Sub

Ich bin sicher, dieser Code kann wesentlich verbessert werden. Danke für eure Hilfe.

[Kuwer]

Hallo Sonja,

z.B. so:

Code:

Sub Untertitel_2()
  Dim lngA As Long, lngZ As Long
  Dim rngA As Range, rngB As Range
  Dim varB As Variant

  Set rngB = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
  
  With rngB
    .Replace What:="=- ", Replacement:=" "
    .Replace What:="- ", Replacement:=" "
    .Replace What:="=", Replacement:=" "
  End With
  
  ReDim varB(1 To rngB.Rows.Count, 1 To 1)
  
  For Each rngA In rngB.SpecialCells(xlCellTypeConstants).Areas
    lngA = lngA + 1
    varB(lngA, 1) = rngA.Cells(1, 1).Value
    For lngZ = 2 To rngA.Rows.Count
      varB(lngA, 1) = varB(lngA, 1) & "  " & rngA.Cells(lngZ, 1).Value
    Next lngZ
  Next rngA
  
  rngB.Value = varB
  rngB.EntireColumn.AutoFit
End Sub

Gruß Uwe