VBA - pomóż mi poprawić ten kod
By mewashoo w poniedziałek, 05 lipca 2021 r
Opublikowany w przewyższać
Odpowiedzi 0
Lubi 0
odwiedzajacy 2.5 tysięcy
Głosów 0
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! 
Wyświetl pełny post