Excel hängt sich auf
08.09.2022 10:48:44
Mark
ich habe mir in Excel ein Marko erstellt um Werte aus einzelnen Dateien auszulesen und in einer gesamt Datei zu kopieren. Jedoch hängt sich das Programm immer während des Ausführen auf. Kann mir jemand helfen?
Nachfolgend mein Code:
Sub SPAuslesen()
Dim wsSpleissplan As Worksheet
Dim wsDatenbank As Worksheet
Dim findFaserDB As Range
Dim findFaserSP As Range
Dim findKabelSP As Range
Dim findKabelDB As Range
Dim findStrasseSP As Range
Dim findStrasseDB As Range
Dim findHsnrSP As Range
Dim findHsnrDB As Range
Dim findKsDB As Range
Dim findKsSP As Range
Dim findSpeicherOrtDB As Range
Dim findPopDB As Range
Dim findDateiDB As Range
Dim i As Integer
Dim n As Integer
Dim w As Integer
Dim u As Integer
Dim x As Integer
Dim h As Integer
Dim g As Integer
Dim q As Integer
Dim Verzeichnis(3000) As String
Dim e As Integer
Dim b As Integer
Dim y As Integer
Dim objFSO As Object
Dim fold As Object
Dim strPfad As String
Dim subFolder As Object, colSubfolders As Object
Dim FS As Object, folder As Object, File As Object
Dim Ordner(300) As String
Dim Datei(3000) As String
Dim Dateikopie(3000) As String
Dim NotOpen(9999999) As String
Dim slashPos As Integer
Dim strPfaddatei As String
Dim strDatei As String
n = 1
i = 1
w = 0
u = 0
Z = 0
e = 0
y = 0
c = 0
j = 0
b = 0
g = 0
q = 0
h = 6
On Error GoTo Fehlerverarbeitung
strPfad = "O:\9D_Netzplanung_und_Bau\03_Bauakte_BuDi"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set fold = objFSO.GetFolder(strPfad)
Set colSubfolders = fold.Subfolders
For Each subFolder In colSubfolders
Ordner(e) = subFolder.Name
e = e + 1
Next subFolder
Set folder1 = Nothing
Set colSubfolders = Nothing
Set objFSO = Nothing
For j = 0 To e - 1
Set FS = CreateObject("Scripting.FileSystemObject")
Set folder = FS.GetFolder("O:\9D_Netzplanung_und_Bau\03_Bauakte_BuDi\" & Ordner(j) & "\03 - Planunterlagen\Spleißpläne")
For Each File In folder.Files
If File.Name Like "*KS*.xlsx" Then
If Not File.Name Like "*Kopie*" Then
Verzeichnis(y) = "O:\9D_Netzplanung_und_Bau\03_Bauakte_BuDi\" & Ordner(j) & "\03 - Planunterlagen\Spleißpläne\" & File.Name
Datei(y) = File.Name
ActiveSheet.Cells(7 + y, 35) = Datei(y)
y = y + 1
End If
End If
Next
Next j
Do While u If Verzeichnis(u) "" Then
Set wsDatenbank = Workbooks("Testdatei 1.0 - Kopie - Kopie.xlsm").Worksheets("Tabelle1")
Set wsSpleissplan = GetObject(Verzeichnis(u)).Worksheets("Tabelle1")
Set findFaserSP = wsSpleissplan.Range("A9:AX12").Find(what:="Faser")
Set findFaserDB = wsDatenbank.Range("A1:X12").Find(what:="Faser")
Set findKabelSP = wsSpleissplan.Range("A9:AX12").Find(what:="Kabel-Nr.")
Set findKabelDB = wsDatenbank.Range("A1:X12").Find(what:="Kabel-Nr.")
Set findStrasseSP = wsSpleissplan.Range("A9:AX12").Find(what:="Straße")
Set findStrasseDB = wsDatenbank.Range("A1:X12").Find(what:="Straße")
Set findHsnrSP = wsSpleissplan.Range("A9:AX12").Find(what:="Hs-Nr.")
Set findHsnrDB = wsDatenbank.Range("A1:X12").Find(what:="Hs-Nr.")
Set findSpeicherOrtDB = wsDatenbank.Range("A1:X12").Find(what:="Speicherort")
Set findPopDB = wsDatenbank.Range("A1:X12").Find(what:="PoP")
Set findDateiDB = wsDatenbank.Range("A1:X12").Find(what:="Datei")
x = wsDatenbank.Cells(wsDatenbank.Rows.Count, findFaserSP.Column).End(xlUp).Offset(1).Row
Do While n If wsSpleissplan.Cells(findFaserSP.Row + i, findFaserSP.Column) "" Then
wsSpleissplan.Cells(findFaserSP.Row + i, findFaserSP.Column).Copy _
wsDatenbank.Cells(x, findFaserDB.Column)
wsSpleissplan.Cells(findFaserSP.Row + i, findKabelSP.Column).Copy _
wsDatenbank.Cells(x, findKabelDB.Column)
wsDatenbank.Cells(x, findPopDB.Column) = wsSpleissplan.Cells(4, 4)
slashPos = InStrRev(Verzeichnis(u), "\")
strPfaddatei = Left(Verzeichnis(u), slashPos)
strDatei = Mid(Verzeichnis(u), slashPos + 1)
wsDatenbank.Hyperlinks.Add Cells(x, findSpeicherOrtDB.Column), Address:=strPfaddatei, TextToDisplay:="Link zur Datei"
wsDatenbank.Cells(x, findDateiDB.Column) = strDatei
If wsSpleissplan.Cells(findFaserSP.Row + i, findStrasseSP.Column) = "" Then
wsDatenbank.Cells(x - 1, findStrasseDB.Column).Copy _
wsDatenbank.Cells(x, findStrasseDB.Column)
If wsSpleissplan.Cells(findFaserSP.Row + i - 1, findStrasseSP.Column) = "Straße" Then
wsSpleissplan.Cells(findFaserSP.Row + i, findStrasseSP.Column).Copy _
wsDatenbank.Cells(x, findStrasseDB.Column)
End If
Else
wsSpleissplan.Cells(findFaserSP.Row + i, findStrasseSP.Column).Copy _
wsDatenbank.Cells(x, findStrasseDB.Column)
End If
If wsSpleissplan.Cells(findFaserSP.Row + i, findHsnrSP.Column) = "" Then
wsDatenbank.Cells(x - 1, findHsnrDB.Column).Copy _
wsDatenbank.Cells(x, findHsnrDB.Column)
If wsSpleissplan.Cells(findFaserSP.Row + i - 1, findHsnrSP.Column) = "Hs-Nr." Then
wsSpleissplan.Cells(findFaserSP.Row + i, findHsnrSP.Column).Copy _
wsDatenbank.Cells(x, findHsnrDB.Column)
End If
Else
wsSpleissplan.Cells(findFaserSP.Row + i, findHsnrSP.Column).Copy _
wsDatenbank.Cells(x, findHsnrDB.Column)
End If
i = i + 1
n = 1
x = x + 1
Else
n = n + 1
i = i + 1
End If
Loop
n = 1
i = 1
Workbooks(Datei(b)).Close
b = b + 1
Else
u = 999999
End If
u = u + 1
Loop
Exit Sub
Fehlerverarbeitung:
NotOpen(g) = Verzeichnis(u)
ActiveSheet.Cells(h, 27).Value = NotOpen(g)
Resume Next
h = h + 1
g = g + 1
End Sub
Sub test()
Dim objFSO As Object
Dim folder As Object
Dim strPfad As String
Dim subFolder As Object, colSubfolders As Object
Dim e As Integer
Dim Ordner(100) As String
e = 0
strPfad = "O:\9D_Netzplanung_und_Bau\03_Bauakte_BuDi"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set folder = objFSO.GetFolder(strPfad)
Set colSubfolders = folder.Subfolders
For Each subFolder In colSubfolders
e = e + 1
Ordner(i) = subFolder.Name
MsgBox "Test:" & Ordner(i)
Next subFolder
Set folder = Nothing
Set colSubfolders = Nothing
Set objFSO = Nothing
End Sub