Hi guys,
miło was wszystkich poznać, czytam wasz portal od dłuższego czasu i korzystam z wielu kodów stąd.
Proszę, czy mógłbyś mi pomóc z poniższym? 1 działa bardzo wolno podczas pracy na większych arkuszach kalkulacyjnych (może zająć 10 minut lub po prostu zawiesić się, gdy ponad 1500 rekordów). Wtórny to nawet nie zadziała, dając błąd 1004, jeśli zapomnę zrobić CTRL + A, mimo że na początku jest wybór/aktywacja zakresu.
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
Każda pomoc byłaby bardzo mile widziana !!!!!
Serdecznie pozdrawiam was wszystkich!