New

VBA - help me deze code te verbeteren

  Excel
mewashoo
  mewashoo
  Maandag 05 juli 2021
  0 Antwoorden
  2.5K bezoeken
0
Stemmen
ongedaan maken
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. 



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! 
0
Er zijn nog geen reacties op dit bericht geplaatst.