VBA Code Optimieren Beschleunigen
19.09.2017 11:33:30
Manuela
Ich habe da einen Code geschrieben der zwar Funktioniert aber meinem Geschmack nach viel zu lange dauert.
Kann einer den Code so Optimieren das dass ganze etwas beschleunigt ?
Wäre super und sehr lieb von euch.
Gruß
Manuela
Es sind 4 Schaltflächen mit so einer Odernerliste 1-4
Sub Ordnerliste_1()
Dim fs, f, f1, fc, s, i
Application.DisplayAlerts = False
'Spalte Löschen
Range("A2:B1000").Select
Selection.ClearContents
Call Netzlaufwerke_verbinden
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("\\192.168.2.2\")
Set fc = f.SubFolders
Cells(2, 1) = f
i = 3
For Each f1 In fc
Cells(i, 1) = f1.Name
i = i + 1
Next
i = 3
For Each f1 In fc
Cells(i, 2) = f1.Name
i = i + 1
Next
'Alles nach dem _ wird entfernt
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="_", FieldInfo:=Array(Array(1, 1), Array(2, 9), Array(3, 9)), _
TrailingMinusNumbers:=True
Range("A1").Select
Application.DisplayAlerts = True
Call Netzlaufwerke_trennen
End Sub
Sub Netzlaufwerke_verbinden()
Dim objFSO As Object, objNetzwerk As Object
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objNetzwerk = CreateObject("WScript.Network")
objNetzwerk.MapNetworkDrive "W:", "\\192.168.2.2\", False, "XX", "XXX"
objNetzwerk.MapNetworkDrive "X:", "\\192.168.2.19\", False, "XX", "XXX"
objNetzwerk.MapNetworkDrive "Y:", "\\192.168.2.1\", False, "XX", "XXX"
objNetzwerk.MapNetworkDrive "Z:", "\\192.168.2.107\", False, "XX", "XXX"
On Error GoTo 0
DoEvents
If objFSO.DriveExists("W:") Then
End If
If objFSO.DriveExists("X:") Then
End If
If objFSO.DriveExists("Y:") Then
End If
If objFSO.DriveExists("Z:") Then
End If
Set objNetzwerk = Nothing
Set objFSO = Nothing
End Sub
Sub Netzlaufwerke_trennen()
Dim objNetzwerk As Object
Set objNetzwerk = CreateObject("WScript.Network")
On Error Resume Next
objNetzwerk.RemoveNetworkDrive "W:"
objNetzwerk.RemoveNetworkDrive "X:"
objNetzwerk.RemoveNetworkDrive "Y:"
objNetzwerk.RemoveNetworkDrive "Z:"
Set objNetzwerk = Nothing
End Sub