ciao anthony,
la macro funge, ma c'è un problema sul foglio e nella colonna filtrata, ricopia sempre la stessa stringa, cioè quella della prima riga.
ho controllato anche col file scaricato da dropbox, fa la stessa cosa.
Moderatori: Anthony47, Flash30005
Sheets(OutSh).Cells(Rows.Count, OutCol).End(xlUp).Offset(1, 0).Resize(NextOut, 1).Value = Application.WorksheetFunction.Transpose(OuArr)
Aspettiamo con impazienzauna Hola e un grazie, alla prossima che sicuramente non mancherà
Ho cercato e cercato, ma nella colonna A di Foglio1 non ho trovato nessuna stringa presente nell' elenco Array("Y1", "YC1", "YM1").
- Codice: Seleziona tutto
StrSh = "Foglio1" '<<< Il foglio con l'elenco di partenza
StrCol = "A" '<<< La colonna dell'elenco di partenza
OutSh = "FoglioZ" '<<< Il foglio dove si crea l'elenco filtrato
OutCol = "B" '<<< La colonna dell'elenco filtrato
Sub Filtra44()
'Rem: Filtra su una colonna, copia un range di colonne
Dim OutSh As String, StrSh As String, YesStr, NoStr, LastA As Long, J As Long, myTim As Double
Dim I As Long, cFound As Long, CRowV As String, YesOk As Boolean, NoNOk As Boolean, NCols As Long
Dim NextOut As Long, OuArr(), StrCol As String, OutCol As String, K As Long
'
StrSh = "Foglio1" '<<< Il foglio con l'elenco di partenza
StrCol = "B" '<<< La colonna dell'elenco di partenza
OutSh = "FoglioZ" '<<< Il foglio dove si crea l'elenco filtrato
OutCol = "A:D" '<<< Le colonne che saranno riportate nell'elenco filtrato
'
YesStr = Array("Y1", "YC1", "YM1")
NoStr = Array("YY", "DY", "CY", "EY", "AY", "RY", "OY")
LastA = Cells(Rows.Count, StrCol).End(xlUp).Row
myTim = Timer
Sheets(StrSh).Select
Sheets(OutSh).Range(OutCol).ClearContents
NCols = Range(OutCol).Columns.Count
ReDim OuArr(1 To 10000, 1 To NCols)
For I = 2 To LastA
YesOk = False: NoNOk = False
CRowV = Cells(I, StrCol).Value
For J = LBound(YesStr, 1) To UBound(YesStr, 1)
cFound = InStr(1, CRowV, YesStr(J), vbTextCompare)
If cFound > 0 Then YesOk = True: Exit For
Next J
If YesOk Then
For J = LBound(NoStr, 1) To UBound(NoStr, 1)
cFound = InStr(1, CRowV, NoStr(J), vbTextCompare)
If cFound > 0 Then NoNOk = True: Exit For
Next J
If YesOk And Not NoNOk Then
NextOut = NextOut + 1
For K = 1 To NCols
OuArr(NextOut, K) = Cells(I, K).Value
Next K
' OuArr(NextOut) = CRowV
If NextOut >= 10000 Then
Sheets(OutSh).Cells(Rows.Count, Range(OutCol).Range("A1").Column).End(xlUp).Offset(1, 0).Resize(NextOut, NCols).Value = OuArr
NextOut = 0
End If
End If
End If
Next I
If NextOut > 0 Then
Sheets(OutSh).Cells(Rows.Count, Range(OutCol).Range("A1").Column).End(xlUp).Offset(1, 0).Resize(NextOut, NCols).Value = OuArr
NextOut = 0
End If
MsgBox ("Completato in Sec. " & Format(Timer - myTim, "0.00") & vbCrLf & _
"Processate " & LastA & " linee su foglio " & StrSh & vbCrLf & _
"Create " & Sheets(OutSh).Cells(Rows.Count, Range(OutCol).Range("A1").Column).End(xlUp).Row & " linee su " & OutSh)
End Sub
StrSh = "Foglio1" '<<< Il foglio con l'elenco di partenza
StrCol = "B" '<<< La colonna dell'elenco di partenza
OutSh = "FoglioZ" '<<< Il foglio dove si crea l'elenco filtrato
OutCol = "A:D" '<<< Le colonne che saranno riportate nell'elenco filtrato !!!
Torna a Applicazioni Office Windows
Excel: formula automatica per evidenziare prodotto scaduto Autore: gamma_ray |
Forum: Applicazioni Office Windows Risposte: 3 |
Salvare file excel in formato html escludendo le immagini Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 5 |
formula excel non visualizza risultato Autore: tommasog |
Forum: Applicazioni Office Windows Risposte: 6 |
Excel 2016 - Funzione SCARTO + INDIRETTO Autore: pl1957 |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: Nessuno e 73 ospiti