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!