Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Untertitel aus Textdateien in gewünschtes Excelformat bringen
#1
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.


Angehängte Dateien
.txt   Untertitel Textdatei.txt (Größe: 101,81 KB / Downloads: 5)
.xls   Untertiteldatei Excel.xls (Größe: 460,5 KB / Downloads: 6)
Antwortento top
#2
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
Antwortento top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste