ich habe mit Hilfe von einigen Bekannten, die sich besser als mich mit VBA auskennen, ein Makro erstellt, dass einzelne Laschen aus einer "Master-Datei" als separate Excel-Dateien mit einem vorgegebenen Namen und in einem vorgegbem Pfad abspeichert.
Anbei findet Ihr den Code. Das Makro funktioniert. Dauert allerdings beim ersten Durchlauf etwa 2-3 Sek. bis zum Abspeichern der Datei und ab dem 2. Durchlauf etwa 25-30 Sek. Da ich dieses Makro mehrmals am Tag ausführen muss, kostet mich dies einiges an Zeit und ich wäre euch extremst dankbar, falls ihr paar Tipps für mich hättet!!
Gruß,
Bobi
Option Explicit
Private Sub CB_Exit_Click()
Unload Me
End Sub
Sub GetMoreSpeed(Optional ByVal modus As Boolean = True)Static intcalculation As Integer
If modus = True Then intcalculation = Application.Calculation
With Application
.ScreenUpdating = Not modus
.EnableEvents = Not modus
.Calculation = IIf(modus, xlManual, intcalculation)
End With
End Sub
Private Sub CB_Save_Click()
Dim Name As String
GetMoreSpeed True
If CboBx_Knd = "" Then MsgBox "Sie müssen schon einen Kunden auswählen!": Exit Sub
ThisWorkbook.Windows(1).SelectedSheets.Copy
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
With Me.CboBx_Knd
Name = Application.GetSaveAsFilename(CStr(.List(.ListIndex, 3) & .List(.ListIndex, 2) & _
Format(Now, .List(.ListIndex, 1))), "Microsoft Excel-Arbeitsmappe (*.xlsx), *xlsx", , "Datei speichern unter...")
If Name "" Then _
ActiveWorkbook.SaveAs Filename:=Name, FileFormat:=xlOpenXMLWorkbook, Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End With
ActiveWorkbook.Close
MsgBox "Gespeichert unter """ & Name & """"
Unload Me
GetMoreSpeed False
End Sub
Private Sub CboBx_Knd_Change()
End Sub
Private Sub Label1_Click()
End Sub
Private Sub UserForm_Initialize()
Dim KndArr() As Variant
Dim KndRng As Range
GetMoreSpeed True
Set KndRng = ThisWorkbook.Worksheets("Kundenverzeichnis").Cells(1, 1).CurrentRegion.Offset( _
1)
Set KndRng = KndRng.Resize(KndRng.Rows.Count - 1, KndRng.Columns.Count)
KndArr = KndRng
Sortieren2 KndArr, Array(1)
CboBx_Knd.List = KndArr
GetMoreSpeed False
End Sub
' Code Bobi 2012
Public Sub Sortieren2(vntArray() As Variant, vntSortArray As Variant)
Dim intIndex As Integer
Dim lngIndex1 As Long, lngIndex2 As Long, lngRowsArray() As Long
Dim lngRowsCount As Long, lngRangeCount As Long
Dim vntTemp As Variant
ReDim lngRowsArray(0 To 1, 0 To UBound(vntArray) * 2)
GetMoreSpeed True
'Array für den 1. Sortierlauf
lngRowsArray(0, 0) = LBound(vntArray)
lngRowsArray(0, 1) = UBound(vntArray)
lngRowsCount = 1
For intIndex = LBound(vntSortArray) To UBound(vntSortArray)
'Wenn eine Spalte angegeben
If vntSortArray(intIndex) 0 Then
lngRangeCount = -1
'Schleife zum sortieren der einzelnen Bereiche
For lngIndex1 = 0 To lngRowsCount Step 2
'Sortieren des Bereichs, wenn Zeilenzahl größer 1
If lngRowsArray(0, lngIndex1) lngRowsArray(0, lngIndex1 + 1) Then
Call prcQuickSort(CLng(lngRowsArray(0, lngIndex1)), _
CLng(lngRowsArray(0, lngIndex1 + 1)), CInt(Abs(vntSortArray(intIndex))), _
_
CBool(vntSortArray(intIndex) > 0), vntArray())
'sortierten Bereich merken
lngRangeCount = lngRangeCount + 2
lngRowsArray(1, lngRangeCount - 1) = lngRowsArray(0, lngIndex1)
lngRowsArray(1, lngRangeCount) = lngRowsArray(0, lngIndex1 + 1)
End If
Next
lngRowsCount = -1
'Durchsuchen der soeben sortierten Spalte nach Wertewechsel
For lngIndex1 = 0 To lngRangeCount Step 2
'1. Zeile des zu sortierenden Bereichs
vntTemp = vntArray(lngRowsArray(1, lngIndex1), Abs(vntSortArray(intIndex)))
lngRowsCount = lngRowsCount + 1
lngRowsArray(0, lngRowsCount) = lngRowsArray(1, lngIndex1)
'Suche nach Wechsel innerhalb des Bereichs
For lngIndex2 = lngRowsArray(1, lngIndex1) To lngRowsArray(1, lngIndex1 + 1)
If vntTemp vntArray(lngIndex2, Abs(vntSortArray(intIndex))) Then
lngRowsCount = lngRowsCount + 2
lngRowsArray(0, lngRowsCount - 1) = lngIndex2 - 1
lngRowsArray(0, lngRowsCount) = lngIndex2
vntTemp = vntArray(lngIndex2, Abs(vntSortArray(intIndex)))
End If
Next
'letzte Zeile des zu sortierenden Bereichs
lngRowsCount = lngRowsCount + 1
lngRowsArray(0, lngRowsCount) = lngRowsArray(1, lngIndex1 + 1)
Next
End If
Next
GetMoreSpeed False
End Sub
Private Sub prcQuickSort(lngLbound As Long, lngUbound As Long, _
intSortColumn As Integer, bntSortKey As Boolean, vntArray() As Variant)
Dim intIndex As Integer
Dim lngIndex1 As Long, lngIndex2 As Long
Dim vntTemp As Variant, vntBuffer As Variant
GetMoreSpeed True
lngIndex1 = lngLbound
lngIndex2 = lngUbound
vntBuffer = vntArray((lngLbound + lngUbound) \ 2, intSortColumn)
Do
If bntSortKey Then
Do While vntArray(lngIndex1, intSortColumn) vntBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While vntBuffer > vntArray(lngIndex2, intSortColumn)
lngIndex2 = lngIndex2 - 1
Loop
End If
If lngIndex1 _
vntArray(lngIndex2, intSortColumn) Then
For intIndex = LBound(vntArray, 2) To UBound(vntArray, 2)
vntTemp = vntArray(lngIndex1, intIndex)
vntArray(lngIndex1, intIndex) = _
vntArray(lngIndex2, intIndex)
vntArray(lngIndex2, intIndex) = vntTemp
Next
End If
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
ElseIf lngIndex1 = lngIndex2 Then
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If lngLbound