CSP Dateien in Excel Importieren

NewtonZ4 · 1970-01-01T00:00:00+00:00

Hallo Zusammen, ich habe in einem Ordner (C:\Import) insgesamt 9 CSP Dateien. Die Dateien enthalten Excel Daten. Ich möchte jetzt per VBA die Dateien automatisch in eine Excel Datei importieren. Jede importierte Datei bekommt ihr eigenes Blatt, welches den Namen der Import Datei bekommt. Ich hoffe die Informationen reichen aus und vielen Dank für jede Hilfe Grüße Stefan

Hallo Stefan,
dann probier mal.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub importCSP()
  Dim objWB As Workbook
  Dim strCSP As String, strPath As String, strNewName As String
  Dim intC As Integer, lngCalc As Long

  On Error GoTo ErrExit

  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
  End With

  strPath = "E:\Forum"

  strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")

  strCSP = Dir(strPath & "*.csp", vbNormal)

  Do While strCSP <> ""

    intC = 0

    Set objWB = Workbooks.Open(strPath & strCSP)

    objWB.Sheets(1).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

    strNewName = strCSP

    Do While SheetExist(strNewName)
      intC = intC + 1
      strNewName = strCSP & "(" & intC & ")"
    Loop

    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = strNewName
    objWB.Close False

    strCSP = Dir
  Loop

  ErrExit:

  If Err.Number <> 0 Then
    MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & Err.Description, vbExclamation, "Fehler"
  End If

  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = lngCalc
  End With

  Set objWB = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

Gruß Sepp

Hallo Stefan,
an der Fehlermeldung war eine verbundene Zelle schuld.
Hier der Code mit allen anpassungen.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub importCSP()
  Dim objWB As Workbook
  Dim strCSP As String, strPath As String, strNewName As String
  Dim intC As Integer, lngCalc As Long

  On Error GoTo ErrExit

  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
  End With

  strPath = "E:\Forum"

  strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")

  strCSP = Dir(strPath & "*.csp", vbNormal)

  Do While strCSP <> ""

    intC = 0

    Set objWB = Workbooks.Open(strPath & strCSP)

    objWB.Sheets(1).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

    strNewName = Left(strCSP, Len(strCSP) - 4)

    Do While SheetExist(strNewName)
      intC = intC + 1
      strNewName = Left(strCSP, Len(strCSP) - 4) & "(" & intC & ")"
    Loop

    With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
      .Name = strNewName
      .Cells.UnMerge
      .Rows("1:14").Delete
      .Columns(1).Delete
    End With

    objWB.Close False

    strCSP = Dir
  Loop

  ErrExit:

  If Err.Number <> 0 Then
    MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & Err.Description, vbExclamation, "Fehler"
  End If

  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = lngCalc
  End With

  Set objWB = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

Gruß Sepp

Forumthread: CSP Dateien in Excel Importieren

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

CSP Dateien in Excel Importieren

Forumthread: CSP Dateien in Excel Importieren

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread