VBA - per favore aiutami a migliorare questo codice
By mewashoo lunedì 05 luglio 2021
pubblicato in Excel
Risposte 0
Mi piace 0
Visualizzazioni 2.5K
voti 0
Ciao ragazzi, 
piacere di conoscervi tutti, leggo il vostro portale da molto tempo e ho usato molto codice da qui. 

Per favore, potresti aiutarmi con di seguito? 1 è lentissimo quando si lavora su fogli di calcolo più grandi (poiché potrebbero volerci 10 minuti o semplicemente bloccarsi quando più di 1500 record). Secondario non funzionerà nemmeno, dando errore 1004 se mi dimentico di fare CTRL+A anche se c'è un intervallo di selezione/attivazione all'inizio. 



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


Qualsiasi aiuto sarebbe enormemente apprezzato!!!!! 
Cordiali saluti a tutti voi! 
Visualizza il post completo