Moderatori: Anthony47, Flash30005
Option Explicit
Option Compare Text
Sub Cerca()
Dim F1 As Worksheet: Set F1 = Worksheets("Elenco")
Dim F2 As Worksheet: Set F2 = Worksheets("cerca")
Dim Ur As Long, X As Long, Rg As Long, Rr As Long, Rx As Long, Txt As String
Ur = F2.Range("D" & Rows.Count).End(xlUp).Row
If Ur > 6 Then F1.Range("D7:H" & Ur) = ""
Ur = F1.Range("D" & Rows.Count).End(xlUp).Row
Txt = F2.Range("D4")
If Txt = "" Then Exit Sub
Rr = 7
Rg = Rr
F1.Activate
For X = 7 To Ur
F1.Range("D" & X).Activate
F1.Cells.Find(What:=Txt, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Rx = Selection.Row
If Rg <> Rx Then
F1.Range(F1.Cells(Rx, "D"), F1.Cells(Rx, "H")).Copy
F2.Range("D" & Rr).PasteSpecial
Rg = Rx
Rr = Rr + 1
X = Rx + 1
End If
Next
F2.Activate
Set F1 = Nothing
Set F2 = Nothing
End Sub
mi riporta solo la prima riga che trova
e non tutte le righe con stessa parola/frase
Private Sub CB1_Click()
oPos.Resize(10000, 5).Clear '.ClearContents ??
If UBound(sArr, 2) > 1 Then
oPos.Resize(UBound(sArr), UBound(sArr, 2)).Value = sArr
Else
oPos.Resize(UBound(sArr, 2), UBound(sArr)).Value = Application.WorksheetFunction.Transpose(sArr)
End If
Application.Goto Sheets("cerca").Range("D6")
'Unload Me ' VEDI TESTO
End Sub
se il risultato e' su 1 sola riga l'output viene sbagliato
Option Explicit
Option Compare Text
Sub Cerca()
Dim F1 As Worksheet: Set F1 = Worksheets("Elenco")
Dim F2 As Worksheet: Set F2 = Worksheets("cerca")
Dim Ur As Long, X As Long, Rg As Long, Rr As Long, Rx As Long, Txt As String
Ur = F2.Range("D" & Rows.Count).End(xlUp).Row
If Ur > 6 Then F2.Range("D7:H" & Ur).Clear
Ur = F1.Range("D" & Rows.Count).End(xlUp).Row
Txt = F2.Range("D4")
If Txt = "" Then Exit Sub
Rr = 7
Rg = Rr
Application.ScreenUpdating = False
F1.Activate
For X = 7 To Ur
F1.Range("D" & X).Activate
F1.Cells.Find(What:=Txt, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Rx = Selection.Row
If Rg <> Rx Then
If Rx < Rg Then GoTo Fine
F1.Range(F1.Cells(Rx, "D"), F1.Cells(Rx, "H")).Copy
F2.Range("D" & Rr).PasteSpecial
Rg = Rx
Rr = Rr + 1
X = Rx
End If
Next
Fine:
F2.Activate
Application.ScreenUpdating = True
Set F1 = Nothing
Set F2 = Nothing
MsgBox "Fatto"
End Sub
Option Explicit
Option Compare Text
Sub Cerca2()
Dim F1 As Worksheet: Set F1 = Worksheets("Elenco")
Dim F2 As Worksheet: Set F2 = Worksheets("cerca")
Dim Ur As Long, X As Long, Rr As Long, Ri As Long, Rx As Long, Txt As String, Rg As Object
Ur = F2.Range("D" & Rows.Count).End(xlUp).Row
If Ur > 6 Then F2.Range("D7:H" & Ur).Clear
Ur = F1.Range("D" & Rows.Count).End(xlUp).Row
Txt = F2.Range("D4")
If Txt = "" Then MsgBox "Inserisci una parola in D4": Exit Sub
Ri = 7
Rr = 7
For X = 7 To Ur
Set Rg = F1.Range("D" & Ri & ":H" & Ur).Find(Txt, LookIn:=xlValues, LookAt:=xlPart)
If Rg Is Nothing Then
GoTo Fine
Else
Rx = Rg.Row
F1.Range(F1.Cells(Rx, "D"), F1.Cells(Rx, "H")).Copy
F2.Range("D" & Rr).PasteSpecial
Rr = Rr + 1
Ri = Rx + 1
X = Rx
End If
Next
Fine:
Set F1 = Nothing
Set F2 = Nothing
Set Rg = Nothing
MsgBox "Fatto"
End Sub
Private sArr(), iSort As Long, noSort As Boolean 'MMMM
Private Sub UserForm_Initialize() 'MMMMM
Dim sArr(), SRan As Range
'
noSort = True
'
Set DBBase = Sheets("film").Range("D8") '<<< L'inizio del database
DBLargh = 6 '<<< Quante colonne esaminare
Set oPos = Sheets("cerca").Range("D7") '<<< Dove scrivere i risultati filtrati
'
Set SRan = Range(DBBase, DBBase.End(xlDown).Offset(0, DBLargh - 1)) 'This is the Row Source
Me.OptionButton1 = True
'Set SRan = Range(Range("B2"), Range("B2").End(xlDown).End(xlToRight))
ReDim sArr(1 To SRan.Rows.Count, 1 To SRan.Columns.Count)
sArr = SRan.Value
sArr = bbSort(sArr)
Me.ListBox1.List = sArr
noSort = False
End Sub
Function bbSort(ByVal lArr) As Variant 'MMMM
Dim tTmp
If noSort Or Me.TextBox1.Value = " " Then bbSort = lArr: Exit Function 'exit senza Sort
'Ripristina typenames:
For i = LBound(sArr) To UBound(sArr)
For j = LBound(sArr, 2) To UBound(sArr, 2)
lArr(j, i) = sArr(i, j)
Next j
Next i
'
On Error Resume Next
UB2 = UBound(lArr, 2)
On Error GoTo 0
If iSort < 50 And UB2 > 1 Then
lb0 = LBound(lArr)
For i = lb0 To UBound(lArr) - 1
For j = i + 1 To UBound(lArr)
If (lArr(i, lb0 + iSort)) > (lArr(j, lb0 + iSort)) Then 'eliminato UCase !!
For k = LBound(lArr, 2) To UBound(lArr, 2)
tTmp = lArr(j, k)
lArr(j, k) = lArr(i, k)
lArr(i, k) = tTmp
Next k
End If
Next j
Next i
End If
bbSort = lArr
End Function
Sinceramente e' diventato poco lineare, trattandosi di una realizzazione fatta per un utente, adattata per un altro, modificata per un altro, adattata per te... Insomma alla prossima revisione mi converrà ripensare tutto!
Torna a Applicazioni Office Windows
Archivio da orizzontale a verticale colorato Autore: ikwae |
Forum: Applicazioni Office Windows Risposte: 6 |
Trova 4005 Coppie Numeri In Archivio Autore: scanacc |
Forum: Applicazioni Office Windows Risposte: 12 |
Evidenziare in archivio blocchi dall'1 al 90 Autore: ikwae |
Forum: Applicazioni Office Windows Risposte: 9 |
Visitano il forum: Nessuno e 23 ospiti