Moderatori: Anthony47, Flash30005
alfrimpa ha scritto:Il link al file non funziona!
Private Sub Workbook_Open()
Sheets("Dati").Range("A1") = Int(Now)
End Sub
'.. codice esistente
'..
MsgBox (" Dati Incompleti")
End
End If
'PRIMO BLOCCO DA AGGIUNGERE >>>
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'<<< FINE BLOCCO
Range("Riga_dati").Select
Selection.Copy
'..
'..
'..
'..
Range("A1").Select
'Range("Data").Select
'SECONDO BLOCCO DA AGGIUNGERE >>>
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.Calculate
'<<< FINE BLOCCO
End Sub
Dim wArr, ELock As Boolean 'Rigorosamente IN TESTA al modulo
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$C$11" Then
'Fill WArr:
With Sheets("Descrizione articoli")
wArr = .Range(.Range("B12"), .Range("B10000").End(xlUp)).Value
End With
With Me.TBFiltro
.Text = " "
.Text = ""
.Visible = True
.Top = Target.Top
.Left = Target.Offset(0, 1).Left
.Width = Target.Width
.Height = Target.Height
.BackColor = RGB(255, 255, 0)
End With
With Me.LBFiltro
.Visible = True
.Top = Me.TBFiltro.Top + Me.TBFiltro.Height + 2
.Left = Me.TBFiltro.Left
.Width = Me.TBFiltro.Width * 1.5
.Height = Target.Height * 3 + 50
.BackColor = RGB(255, 255, 200)
End With
Me.TBFiltro.Activate
Else
Me.TBFiltro.Visible = False
Me.LBFiltro.Visible = False
End If
End Sub
Private Sub lbfiltro_Click()
'
If ELock = False Then
Debug.Print LBFiltro.ListIndex, LBFiltro.Value
Range("C11") = Me.LBFiltro.Value
Range("C12").Select
Else
Debug.Print "LOCKED", LBFiltro.ListIndex, LBFiltro.Value
End If
End Sub
Private Sub TBFiltro_Change()
Dim lArr(), I As Long, J As Long, TBTxt As String, LBH As Long
'
ELock = True
'If IsEmpty(wArr) Then
' With Sheets("Descrizione articoli")
' wArr = .Range(.Range("B12"), .Range("B10000").End(xlUp)).Value
' End With
'End If
ReDim lArr(1 To UBound(wArr))
TBTxt = Me.TBFiltro.Text
For I = 1 To UBound(wArr)
If InStr(1, wArr(I, 1), TBTxt, vbTextCompare) > 0 Then
J = J + 1
lArr(J) = wArr(I, 1)
End If
Next I
If J = 0 Then J = 1
ReDim Preserve lArr(1 To J)
Me.LBFiltro.List = lArr
For I = 0 To LBFiltro.ListCount - 1
LBFiltro.Selected(I) = False
Next I
ELock = False
End Sub
Function FornitAll(ByVal myItm As String, myMov As Range) As Variant
Dim oArr(), supArr(), WArr, I As Long, myUCItm As String
Dim dLayout, myMatch, J As Long
'
ReDim oArr(1 To Application.Caller.Rows.Count, 1 To Application.Caller.Columns.Count)
ReDim supArr(1 To Application.Caller.Rows.Count)
For I = 1 To UBound(oArr)
For J = 1 To UBound(oArr, 2)
oArr(I, J) = "....."
Next J
Next I
J = 0
dLayout = Array(2, 11, 1, 12) '<<< Le colonne di Articolo, Fornitore, Data, Prezzo
WArr = myMov.Value
myUCItm = UCase(myItm)
For I = 1 To UBound(WArr)
If UCase(WArr(I, dLayout(0))) = myUCItm Then
myMatch = Application.Match(WArr(I, dLayout(1)) & "ZZ", supArr, False)
If IsError(myMatch) Then
J = J + 1
If J > UBound(oArr) Then
oArr(J - 1, 1) = ". altro ."
oArr(J - 1, 2) = ". altro ."
oArr(J - 1, 3) = ". altro ."
Exit For
End If
supArr(J) = WArr(I, dLayout(1)) & "ZZ"
oArr(J, 1) = WArr(I, dLayout(1))
oArr(J, 2) = WArr(I, dLayout(3))
oArr(J, 3) = WArr(I, dLayout(2))
Else
If WArr(I, dLayout(2)) > oArr(myMatch, 3) Then
oArr(myMatch, 1) = WArr(I, dLayout(1))
oArr(myMatch, 2) = WArr(I, dLayout(3))
oArr(myMatch, 3) = WArr(I, dLayout(2))
End If
End If
End If
Next I
FornitAll = oArr
End Function
=FornitAll(A1;'Archivio Movimentazioni'!B14:M5500)
FornitAll(DescrizioneProdotto;AreaDelleMovimentazioni)
=FornitAll("carote";'Archivio Movimentazioni'!B14:M5500)
Torna a Applicazioni Office Windows
Problema softwere gestionale con programma Access Autore: Franz76 |
Forum: Applicazioni Office Windows Risposte: 1 |
Schiacciamento righe - somma quantità articoli (macro?) Autore: alis |
Forum: Applicazioni Office Windows Risposte: 6 |
Mille CD musicali da mettere online Autore: Licantropo |
Forum: Audio/Video e masterizzazione Risposte: 14 |
Visitano il forum: Nessuno e 24 ospiti