08.05.2016, 21:45
Hallo liebe Excelgemeinde,
habe folgenden Code gebastelt um Rechnungsdaten zu importieren:
Dieser funktoniert prima und macht genau das was er soll, allerdings je mehr DAtensätze ich habe umso länger benötigt der Code um dies durchzulaufen!
Kann mir jemand helfen um diesen schneller zu machen?
Vielen Dank
VG
Alexandra
habe folgenden Code gebastelt um Rechnungsdaten zu importieren:
Code:
Private Sub Rechnungsprüfung()
wahl = MsgBox("Neue Rechnungsdaten importieren?", vbYesNo)
If wahl <> 6 Then Exit Sub
Dim loZeile1 As Long, loZeile2 As Long
Dim Datei As Object
Dim Wert1 As String
Dim Wert2 As String
Dim Wert3 As String
Dim WS As Worksheet
Dim WS2 As Worksheet
Dim neueDatei As String
Dim NameOhneXLSX As String
Dateiname = Application.GetOpenFilename("Excel Datei, *.*") ' Datei auswählen
If Dateiname = "Falsch" Then Exit Sub ' bei Abbruch
Application.ScreenUpdating = True
Dim var
var = MsgBox("Import der Rechnungsdaten starten? ", vbYesNo)
If var = 7 Then
Exit Sub
Else
Set Datei = Workbooks.Open(Dateiname) ' Datei öffnen
Set WS = Workbooks(ActiveWorkbook.Name).Worksheets(1)
loZeile1 = WS.Cells(Rows.Count, 2).End(xlUp).Row
Workbooks("Rechnungen2016.xlsm").Activate
Set WS2 = Workbooks(ActiveWorkbook.Name).Worksheets(1)
loZeile2 = WS2.Cells(Rows.Count, 2).End(xlUp).Row
For i = 6 To loZeile1
Wert1 = WS.Range("K" & i).Value
Wert3 = WS.Range("AZ" & i).Value
Wert4 = WS.Range("B" & i).Value
Wert5 = WS.Range("Y" & i).Value
Wert6 = WS.Range("AJ" & i).Value
Wert7 = WS.Range("D" & i).Value
Wert8 = WS.Range("J" & i).Value & "/" & WS.Range("K" & i).Value
Wert9 = WS.Range("W" & i).Value & " / " & WS.Range("X" & i).Value & " / " & WS.Range("AB" & i).Value
Wert10 = WS.Range("J" & i).Value & "/" & WS.Range("K" & i).Value
Wert12 = WS.Range("R" & i).Value & " * " & WS.Range("T" & i).Value & " * " & WS.Range("U" & i).Value
booGefunden = False
For k = 8 To loZeile2
Wert2 = WS2.Range("B" & k).Value
Wert11 = ThisWorkbook.Sheets("Diverse").Range("B" & k).Value
If Wert1 = Wert2 Then
WS2.Range("G" & k).Cells.Activate
ActiveWindow.ScrollRow = ActiveWindow.ActiveCell.Row
ActiveWindow.SmallScroll Down:=-20
WS2.Range("G" & k).Value = CDbl(Wert3)
WS2.Range("I" & k).Value = Wert4
WS2.Range("B" & k).Formula = "85/" & WS2.Range("B" & k)
booGefunden = True
Else
If Wert10 = Wert2 Or Wert10 = Wert11 Then
wahl = MsgBox("Rechnungsdaten zur Sendung " & Wert10 & " bereits vorhanden! Nächste Sendung?", vbYesNo)
If wahl <> 6 Then Exit Sub
'MsgBox "Rechnungsdaten zur Sendung " & Wert10 & " bereits vorhanden!"
booGefunden = True
Exit For
End If
End If
Next k
If booGefunden = False Then
Sheets("Diverse").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert9
Range("B65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert8
Range("C65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert5
Range("D65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert6
Range("E65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert7
Range("F65536").End(xlUp).Offset(1, 0).Select
Selection.Value = CDbl(Wert3)
Range("G65536").End(xlUp).Offset(1, 0).Select
Selection.Value = CDbl(Wert3)
Range("I65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert4
Application.ScreenUpdating = False
AufhebenTemp
Application.ScreenUpdating = True
With ActiveCell
Range(Cells(.Row, 1), Cells(.Row, 9)).Select
Selection.Interior.ColorIndex = 6
End With
wahl = MsgBox("Sendung " & Wert10 & " * " & Wert12 & " nicht gefunden! Sendung OK?", vbYesNo)
If wahl <> 6 Then
With ActiveCell
Range(Cells(.Row, 1), Cells(.Row, 9)).Select
Selection.Interior.ColorIndex = xlNone
End With
ActiveCell.EntireRow.ClearContents
BlattSchutz
MsgBox "Sendung " & Wert10 & " gelöscht!"
End If
AufhebenTemp
With ActiveCell
Range(Cells(.Row, 1), Cells(.Row, 9)).Select
Selection.Interior.ColorIndex = xlNone
End With
BlattSchutz
'MsgBox "Sendung " & Wert10 & " nicht gefunden! Bitte prüfen!"
Sheets("Versand").Select
End If
Next i
neueDatei = Datei.Path & "\" & Datei.Name ' Datei.Path & "\" &
NameOhneXLSX = Left(neueDatei, Len(neueDatei) - 5)
Datei.Close SaveChanges:=False
Name neueDatei As NameOhneXLSX & " - " & Format(Now, "yyyy_mm_dd_hhmm") & ".xlsx"
MsgBox ("Import Rechnungsdaten abgeschlossen!")
End If
Worksheets("Versand").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Worksheets("Diverse").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
ThisWorkbook.Activate
Call Aktualisieren
End Sub
Kann mir jemand helfen um diesen schneller zu machen?
Vielen Dank
VG
Alexandra