Hi guys,
leuk jullie allemaal te ontmoeten, ik heb je portaal al een hele tijd gelezen en heb veel code van hier gebruikt.
Kunt u mij alstublieft helpen met onderstaande? 1 is het erg traag bij het werken aan grotere spreadsheets (zoals in het kan 10 minuten duren of gewoon vastlopen bij meer dan 1500 records). Secundair zal het niet eens werken, het geeft een 1004-fout als ik vergeet CTRL + A uit te voeren, ook al is er een bereik selecteren / activeren aan het begin.
Alle hulp wordt enorm gewaardeerd!!!!!
Vriendelijke groeten aan jullie allemaal!
leuk jullie allemaal te ontmoeten, ik heb je portaal al een hele tijd gelezen en heb veel code van hier gebruikt.
Kunt u mij alstublieft helpen met onderstaande? 1 is het erg traag bij het werken aan grotere spreadsheets (zoals in het kan 10 minuten duren of gewoon vastlopen bij meer dan 1500 records). Secundair zal het niet eens werken, het geeft een 1004-fout als ik vergeet CTRL + A uit te voeren, ook al is er een bereik selecteren / activeren aan het begin.
Sub Importer()
Dim numberrowE, numberrowI, numberrowP As Integer
Dim e, I, p As Integer
Dim cell As Range
ActiveSheet.Range("A1:ZZ25000").Activate
'ActiveSheet.Select
'Loop Through Each Cell
For Each cell In Selection.Cells
If cell.Interior.Color = 6 Then
cell.Interior.Color = 0
End If
Next
Dim j, k As Double
numberrowE = Worksheets("References").Range("B4").Value
numberrowI = Worksheets("References").Range("B6").Value
numberrowP = Worksheets("References").Range("B8").Value
With Application
.EnableEvents = False
.ScreenUpdating = False
.CutCopyMode = False
.Calculation = xlCalculationManual
End With
For e = 2 To numberrowE
' Labour
If ActiveWorkbook.Worksheets("Data").Cells(e, 17) = ActiveSheet.Range("B5") Then 'check if same project
If Not IsError(Application.Match(Worksheets("Data").Cells(e, 12), Worksheets("References").Range("D:D"), 0)) Then 'check if name exists in range
If Not InStr(Worksheets("Data").Cells(e, 11), "PORP") = 1 Then 'skip PORP ones
If IsError(Application.Match(Worksheets("Data").Cells(e, 2), ActiveSheet.Range("LabourIDCol"), 0)) Then 'check if invoice number already exists
ActiveSheet.Range("LabourStart").End(xlDown).Offset(1, 0) = Split(Worksheets("Data").Cells(e, 11), " ")(0) 'import Inv No
ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 1) = Worksheets("Data").Cells(e, 9) 'import Inv Date
ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 2) = Worksheets("Data").Cells(e, 12) 'import Name
ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 3) = "=IFERROR(VLOOKUP(RC[-1],References!C:C[1],2,0),"""")"
ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 4) = Worksheets("Data").Cells(e, 13) 'import Inv Value
If Not IsError(Application.Match(ActiveSheet.Range("LabourStart").Offset(0, 1).End(xlDown), Worksheets("References").Range("A:A"), 0)) Then
ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 5) = ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 4) + ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 4).Value * ActiveSheet.Range("N19")
ElseIf IsError(Application.Match(ActiveSheet.Range("LabourStart").Offset(0, 1).End(xlDown), Worksheets("References").Range("A:A"), 0)) Then
ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 5) = ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 4) + ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 4).Value * ActiveSheet.Range("N18")
End If
ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 5).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("LabourStart").End(xlDown).Offset(0, 7) = Worksheets("Data").Cells(e, 2) 'import ID
ActiveSheet.Range("LabourStart").End(xlDown).Offset(2).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
End If
End If
End If
' Materials
If IsError(Application.Match(Worksheets("Data").Cells(e, 12), Worksheets("References").Range("D:D"), 0)) Then 'check if name does not exists in range
If Not InStr(Worksheets("Data").Cells(e, 11), "PORP") = 1 Then 'skip PORP ones
If IsError(Application.Match(Worksheets("Data").Cells(e, 2), ActiveSheet.Range("SuppliersIDCol"), 0)) Then 'check if invoice number already exists
ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(1, 0) = Split(Worksheets("Data").Cells(e, 11), " ")(0) 'import Inv No
ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 1) = Worksheets("Data").Cells(e, 9) 'import Inv Date
ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 2) = Worksheets("Data").Cells(e, 12) 'import Name
ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 3) = "=IFERROR(VLOOKUP(RC[-1],References!C:C[1],2,0),"""")"
ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 4) = Worksheets("Data").Cells(e, 13) 'import Inv Value
If Not IsError(Application.Match(ActiveSheet.Range("SuppliersStart").Offset(0, 1).End(xlDown), Worksheets("References").Range("A:A"), 0)) Then
ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 5) = ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 4) + ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 4).Value * ActiveSheet.Range("N19")
ElseIf IsError(Application.Match(ActiveSheet.Range("SuppliersStart").Offset(0, 1).End(xlDown), Worksheets("References").Range("A:A"), 0)) Then
ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 5) = ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 4) + ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 4).Value * ActiveSheet.Range("N18")
End If
ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 5).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(0, 7) = Worksheets("Data").Cells(e, 2) 'import ID
ActiveSheet.Range("SuppliersStart").End(xlDown).Offset(2).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
End If
End If
End If
' Subcontractors
If InStr(Worksheets("Data").Cells(e, 11), "PORP") = 1 Then 'only PORP ones
If IsError(Application.Match(Worksheets("Data").Cells(e, 2), ActiveSheet.Range("SubconsIDCol"), 0)) Then 'check if invoice number already exists
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(1, 0) = Split(Worksheets("Data").Cells(e, 11), " ")(0) 'import Inv No
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 1) = Worksheets("Data").Cells(e, 9) 'import Inv Date
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 2) = Worksheets("Data").Cells(e, 12) 'import Name
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 4) = Worksheets("Data").Cells(e, 13) 'import Inv Value
If Not IsError(Application.Match(ActiveSheet.Range("SubconsStart").Offset(0, 1).End(xlDown), Worksheets("References").Range("A:A"), 0)) Then
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 5) = ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 4) + ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 4).Value * ActiveSheet.Range("N19")
ElseIf IsError(Application.Match(ActiveSheet.Range("SuppliersStart").Offset(0, 1).End(xlDown), Worksheets("References").Range("A:A"), 0)) Then
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 5) = ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 4) + ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 4).Value * ActiveSheet.Range("N18")
End If
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 5).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 7) = Worksheets("Data").Cells(e, 2) 'import ID
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(2).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
ActiveSheet.Range("SubconOH_PT").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
End If
End If
Next e
For I = 2 To numberrowI
'Incomes
If ActiveWorkbook.Worksheets("Data").Cells(I, 41) = ActiveSheet.Range("B5") Then 'check if same project
If IsError(Application.Match(Worksheets("Data").Cells(I, 28), ActiveSheet.Range("IncomesIDCol"), 0)) Then 'check if invoice number already exists
ActiveSheet.Range("IncomesStart").End(xlDown).Offset(1, 0) = Split(Worksheets("Data").Cells(I, 35), " ")(0) 'import Inv No
ActiveSheet.Range("IncomesStart").End(xlDown).Offset(0, 1) = Worksheets("Data").Cells(I, 33) 'import Inv Date
ActiveSheet.Range("IncomesStart").End(xlDown).Offset(0, 2) = Worksheets("Data").Cells(I, 36) 'import Name
ActiveSheet.Range("IncomesStart").End(xlDown).Offset(0, 3) = "=IFERROR(VLOOKUP(RC[-1],References!C:C[1],2,0),"""")"
If Worksheets("Data").Cells(I, 40).Value = "paid" Then 'check if name exists in range
ActiveSheet.Range("IncomesStart").End(xlDown).Offset(0, 4) = Worksheets("Data").Cells(I, 37) 'import Inv Value
Else
ActiveSheet.Range("IncomesStart").End(xlDown).Offset(0, 4) = "0"
End If
ActiveSheet.Range("IncomesStart").End(xlDown).Offset(0, 5) = "OK" 'import OH
ActiveSheet.Range("IncomesStart").End(xlDown).Offset(0, 7) = Worksheets("Data").Cells(I, 28) 'import ID
ActiveSheet.Range("IncomesStart").End(xlDown).Offset(2).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
End If
End If
Next I
For p = 2 To numberrowP
' Purchase Orders
If ActiveWorkbook.Worksheets("Data").Cells(p, 65) = ActiveSheet.Range("B5") Then 'check if same project
If InStr(Worksheets("Data").Cells(p, 59), "PORP") = 1 Then 'only PORP ones
If IsError(Application.Match(Worksheets("Data").Cells(p, 2), ActiveSheet.Range("SubconsIDCol"), 0)) Then 'check if invoice number already exists
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(1, 0) = Split(Worksheets("Data").Cells(p, 59), " ")(0) 'import Inv No
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 1) = Worksheets("Data").Cells(p, 58) 'import Inv Date
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 2) = Worksheets("Data").Cells(p, 60) 'import Name
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 3) = Worksheets("Data").Cells(p, 61) 'import Inv Value
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 5) = "OK" 'import OH
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(0, 7) = Worksheets("Data").Cells(p, 54) 'import ID
ActiveSheet.Range("SubconsStart").End(xlDown).Offset(2).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Application.CutCopyMode = False
End If
End If
End If
Next p
'Purchase Orders sort and format
ActiveSheet.ListObjects(4).Sort.SortFields.Clear
ActiveSheet.ListObjects(4).Sort.SortFields. _
Add Key:=Range("POnumbersSort"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveSheet.ListObjects(4).Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Labour Sort
ActiveSheet.ListObjects(2).Sort.SortFields.Clear
ActiveSheet.ListObjects(2).Sort.SortFields. _
Add Key:=Range("LabourDateCol"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveSheet.ListObjects(2).Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Supplier sort
ActiveSheet.ListObjects(3).Sort.SortFields.Clear
ActiveSheet.ListObjects(3).Sort.SortFields. _
Add Key:=Range("SupplierDateCol"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveSheet.ListObjects(3).Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Incomes sort
ActiveSheet.ListObjects(5).Sort.SortFields.Clear
ActiveSheet.ListObjects(5).Sort.SortFields. _
Add Key:=Range("IncomesDateCol"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveSheet.ListObjects(5).Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Changes formatting for "accounting"
Range("Accounting").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
With Application
.EnableEvents = True
.ScreenUpdating = True
.CutCopyMode = False
.Calculation = xlCalculationAutomatic
End With
End Sub
Alle hulp wordt enorm gewaardeerd!!!!!
Vriendelijke groeten aan jullie allemaal!