Thema: Schleife Tabellenblätter öffnen Makro ausführen

Sub ImportFromCSV()
Dim strPath As String, strFile As String, strTmp As String
Dim vntText As Variant
Dim lngI As Long, lngN As Long, lngRow As Long, lngEntry As Long

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlManual
  .DisplayAlerts = False
End With

lngRow = 2

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "E:\Forum" 'Startverzeichnis - Anpassen!
  .Title = "CSV-Import Ordnerauswahl"
  .ButtonName = "Import Starten"
  .InitialView = msoFileDialogViewList
  If .Show = -1 Then
    strPath = .SelectedItems(1)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  End If
End With

If Len(strPath) Then
  With ThisWorkbook.Sheets("Tabelle1")
    .Range("A2:H" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)).Clear
    .Range("A:H").NumberFormat = "0"
    strFile = Dir(strPath & "*.csv", vbNormal)
    Do While strFile <> ""
      strTmp = ReadFile(strPath & strFile)
      
      vntText = Split(strTmp, vbCrLf)
      For lngI = 0 To UBound(vntText)
        If LCase(vntText(lngI)) Like "*ebay-artikelnummer:*" Then
          .Hyperlinks.Add Anchor:=.Cells(lngRow, 1), Address:=strPath & "\" & strFile
          .Cells(lngRow, 2) = Val(Trim(vntText(lngI + 1)))
          lngEntry = 1
          For lngN = lngI + 2 To UBound(vntText)
            If LCase(vntText(lngN)) Like "ean*" Then
              .Cells(lngRow, 3) = Split(vntText(lngN), ",")(1)
              lngEntry = 1
            ElseIf LCase(vntText(lngN)) Like "*isbn*" Then
              If LCase(vntText(lngN)) Like "*isbn:*" Then
                .Cells(lngRow, 5) = Val(Replace(Split(vntText(lngN), ":")(1), "-", ""))
              Else
                .Cells(lngRow, 6) = Split(vntText(lngN), ",")(1)
              End If
              lngEntry = 1
            ElseIf LCase(vntText(lngN)) Like "*978*" Then
              .Cells(lngRow, 4) = Split(vntText(lngN), ",")(1)
              lngEntry = 1
            End If
          Next
          Exit For
        End If
      Next
      lngRow = lngRow + lngEntry
      lngEntry = 0
      strFile = Dir
    Loop
  End With
End If

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'ImportFromCSV'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - ImportFromCSV"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlAutomatic
  .DisplayAlerts = True
  .StatusBar = False
End With
End Sub

Sub ImportFromCSV()
Dim strPath As String, strFile As String, strTmp As String
Dim vntText As Variant
Dim lngI As Long, lngN As Long, lngRow As Long, lngEntry As Long

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlManual
  .DisplayAlerts = False
End With

lngRow = 2

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "E:\Forum" 'Startverzeichnis - Anpassen!
  .Title = "CSV-Import Ordnerauswahl"
  .ButtonName = "Import Starten"
  .InitialView = msoFileDialogViewList
  If .Show = -1 Then
    strPath = .SelectedItems(1)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  End If
End With

If Len(strPath) Then
  With ThisWorkbook.Sheets("Tabelle1")
    .Range("A2:H" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)).Clear
    .Range("A:H").NumberFormat = "0"
    strFile = Dir(strPath & "*.csv", vbNormal)
    Do While strFile <> ""
      strTmp = ReadFile(strPath & strFile)
      
      vntText = Split(strTmp, vbCrLf)
      For lngI = 0 To UBound(vntText)
        If LCase(vntText(lngI)) Like "*ebay-artikelnummer:*" Then
          .Hyperlinks.Add Anchor:=.Cells(lngRow, 1), Address:=strPath & "\" & strFile
          .Cells(lngRow, 2) = Val(Trim(vntText(lngI + 1)))
          lngEntry = 1
          For lngN = lngI + 2 To UBound(vntText)
            If LCase(vntText(lngN)) Like "ean*" Then
              .Cells(lngRow, 3) = Split(vntText(lngN), ",")(1)
              lngEntry = 1
            ElseIf LCase(vntText(lngN)) Like "*isbn*" Then
              If LCase(vntText(lngN)) Like "*isbn:*" Then
                .Cells(lngRow, 5) = Val(Replace(Split(vntText(lngN), ":")(1), "-", ""))
              Else
                .Cells(lngRow, 6) = Split(vntText(lngN), ",")(1)
              End If
              lngEntry = 1
            ElseIf LCase(vntText(lngN)) Like "*978*" Then
              .Cells(lngRow, 4) = Split(vntText(lngN), ",")(1)
              lngEntry = 1
            End If
          Next
          Exit For
        End If
      Next
      lngRow = lngRow + lngEntry
      lngEntry = 0
      strFile = Dir
    Loop
  End With
End If

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'ImportFromCSV'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - ImportFromCSV"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlAutomatic
  .DisplayAlerts = True
  .StatusBar = False
End With
End Sub