Moderatori: Anthony47, Flash30005
ipsoware ha scritto:Hai provato con più parole contemporaneamente?
ipsoware ha scritto:Ho applicato la Macro ed effettivamente qualche riga viene eliminata ma solo 55 record.
Ne dovrebbe eliminare decine di migliaia. Quindi qualcosa non funziona. Non vorrei che a te funziona perchè hai provato solo con una parola. Forse non riconosce maiuscole minuscole o gli eventuali spazi prima e dopo la parola di ricerca?
Comunque se riuscissi a risolvere il problema te ne sarei grato.
For J = LBound(Cancella) To UBound(Cancella)
reMatch: '******
vRet = Application.Match("*" & Cancella(J) & "*", rngCol, 0)
If Not IsError(vRet) Then
'MsgBox Cancella(j) & ": " & vRet
rng.Rows(vRet).Delete Shift:=xlUp
GoTo reMatch '******
End If
Next
Sub repulist()
Dim VLine, myMatch, FileToOpen, NomeFile As String, myFlag As Boolean, I As Long
Dim J As Long, K As Long
Dim Cancella(1 To 30) As String
Cancella(1) = "Nero"
Cancella(2) = "tamburo"
Cancella(3) = "MULTILICENZE"
Cancella(4) = "VMWARE"
'etc etc
'
FileToOpen = Application.GetOpenFilename("CSV Files (*.csv), *.csv")
If FileToOpen = False Then
Exit Sub
End If
NomeFile = Right(FileToOpen, Len(FileToOpen) - InStrRev(FileToOpen, "\"))
mycell = FileToOpen
myfile = Replace(FileToOpen, NomeFile, "ZCZC_" & NomeFile)
Close #1: Close #2
Open mycell For Input As #1
Open myfile For Output As #2
'
Do While Not EOF(1)
Line Input #1, VLine
For I = 1 To UBound(Cancella)
If Len(VLine) > Len(Replace(VLine, Cancella(I), "", , , vbTextCompare)) Then
myFlag = True
Exit For
End If
Next I
If myFlag = False Then
Print #2, VLine
J = J + 1
Else
myFlag = False
K = K + 1
End If
Loop
'
Close #1
Close #2
'
MsgBox ("Creato file ZCZC_" & NomeFile & vbCrLf & _
"Record registrati: " & J & vbCrLf & _
"Record eliminati: " & K)
'
End Sub
Anthony47 ha scritto:Personalmente pero' ritengo piu' vantaggioso lavorare sul file di input (il file csv), aprendolo riga per riga, verificando le righe da eliminare e quelle da mantenere, e creando un nuovo file nominato ZCZC_NomeOriginale. A questo punto il tuo processo sara' fatto sul nuovo file.
Credo che questo potrebbe risultare in un tempo di elaborazione drasticamente inferiore rispetto al lavoro fatto sul foglio excel.
'---------------------------------------------------------------------------------------
' Procedure : CancRighe
' Author : scossa
'---------------------------------------------------------------------------------------
'
Public Sub CancRighe()
Dim Cancella(1 To 30) As String
Dim j As Long, nDel As Long, nDelTot As Long
Dim rng As Range
Dim rngDel As Range, rArea As Range
Dim rngCanc As Range
Dim ws As Worksheet
Dim nStart As Single
Dim nStop As Single
Dim bCalc As Boolean
Dim nRet As VbMsgBoxResult
With Application
bCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
On Error GoTo CancRighe_Error
Set ws = ActiveSheet
Set rng = ws.UsedRange
Cancella(1) = "SYMANT"
Cancella(2) = "LICENZE"
Cancella(3) = "MULTILICENZE"
Cancella(4) = "VMWARE"
Cancella(5) = "GARANZIA"
Cancella(6) = "MAINTENAN"
Cancella(7) = "PREVENTIVE"
Cancella(8) = "ESTENSIONE"
Cancella(9) = "SW BTO"
Cancella(10) = "MCAFEE"
Cancella(11) = "RED HA"
Cancella(12) = "WINDOWS SERVER CAL"
Cancella(13) = "ANTI VIRUS"
Cancella(14) = "PANDA"
Cancella(15) = "TREND MICRO"
Cancella(16) = "NUANCE"
Cancella(17) = "APPLICATION"
Cancella(18) = "ENTERPRISE"
Cancella(19) = "COREL"
Cancella(20) = "APPLICATIVI"
Cancella(21) = "VISUAL STDIO"
Cancella(22) = "- MICROS"
Cancella(23) = "ADOBE"
Cancella(24) = "LICENZA"
Cancella(25) = "VEEAM"
Cancella(26) = "AGFA"
Cancella(27) = "MAINTENANCE"
Cancella(28) = "LOTUS"
Cancella(29) = "EXCHANGE"
Cancella(30) = "OBBLIGAT ISS"
nStart = Timer
For j = LBound(Cancella) To UBound(Cancella)
rng.AutoFilter Field:=4, Criteria1:= _
"=*" & Cancella(j) & "*"
Set rngDel = Intersect(rng.Offset(1), rng.SpecialCells(xlCellTypeVisible), ws.Columns(4))
If Not rngDel Is Nothing Then
nDel = rngDel.Cells.Count
Application.StatusBar = "trovate " & Format(nDel, "#,##0") & " righe con: " & Cancella(j)
If rngCanc Is Nothing Then
Set rngCanc = rngDel
Else
Set rngCanc = Union(rngCanc, rngDel)
End If
End If
Next j
rng.AutoFilter
For Each rArea In rngCanc.Areas
nDelTot = nDelTot + rArea.Rows.Count
Next
Application.StatusBar = "elimino le " & Format(nDelTot, "#,##0") & " righe"
rngCanc.EntireRow.Delete
nStop = Timer
Application.StatusBar = "fatto!"
On Error GoTo 0
'Exit Sub
CancRighe_Error:
Set rngCanc = Nothing
Set rngDel = Nothing
Set rng = Nothing
Set ws = Nothing
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.StatusBar = False
End With
If Err.Number <> 0 Then
MsgBox "Error: " & Err.Description, vbCritical, "ERRORE"
Else
MsgBox "elaborazione terminata in" & vbCrLf & nStop - nStart & " secondi" & vbCrLf & _
"cancellate " & Format(nDelTot, "#,##0") & " righe"
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : repulist
' Author : Anthony
'---------------------------------------------------------------------------------------
'
Sub repulist()
Dim VLine, myMatch, FileToOpen, NomeFile As String, myFlag As Boolean, I As Long
Dim J As Long, K As Long
Dim x As Long
Dim mycell, myfile
Dim nStart As Single
Dim nStop As Single
Dim sDesc As String
Dim nAt As Long
Dim Cancella(1 To 30) As String
Cancella(1) = "SYMANT"
Cancella(2) = "LICENZE"
Cancella(3) = "MULTILICENZE"
Cancella(4) = "VMWARE"
Cancella(5) = "GARANZIA"
Cancella(6) = "MAINTENAN"
Cancella(7) = "PREVENTIVE"
Cancella(8) = "ESTENSIONE"
Cancella(9) = "SW BTO"
Cancella(10) = "MCAFEE"
Cancella(11) = "RED HA"
Cancella(12) = "WINDOWS SERVER CAL"
Cancella(13) = "ANTI VIRUS"
Cancella(14) = "PANDA"
Cancella(15) = "TREND MICRO"
Cancella(16) = "NUANCE"
Cancella(17) = "APPLICATION"
Cancella(18) = "ENTERPRISE"
Cancella(19) = "COREL"
Cancella(20) = "APPLICATIVI"
Cancella(21) = "VISUAL STDIO"
Cancella(22) = "- MICROS"
Cancella(23) = "ADOBE"
Cancella(24) = "LICENZA"
Cancella(25) = "VEEAM"
Cancella(26) = "AGFA"
Cancella(27) = "MAINTENANCE"
Cancella(28) = "LOTUS"
Cancella(29) = "EXCHANGE"
Cancella(30) = "OBBLIGAT ISS"
'etc etc
'
FileToOpen = Application.GetOpenFilename("CSV Files (*.csv), *.csv")
If FileToOpen = False Then
Exit Sub
End If
NomeFile = Right(FileToOpen, Len(FileToOpen) - InStrRev(FileToOpen, "\"))
mycell = FileToOpen
myfile = Replace(FileToOpen, NomeFile, "ZCZC_" & NomeFile)
Close #1: Close #2
Open mycell For Input As #1
Open myfile For Output As #2
'
nStart = Timer
Do While Not EOF(1)
Line Input #1, VLine
sDesc = VLine
For x = 1 To 3
nAt = InStr(sDesc, ";")
sDesc = Mid(sDesc, nAt + 1)
Next x
nAt = InStr(sDesc, ";")
sDesc = Left(sDesc, nAt - 1)
For I = 1 To UBound(Cancella)
If Len(sDesc) > Len(Replace(sDesc, Cancella(I), "", , , vbTextCompare)) Then
myFlag = True
Exit For
End If
Next I
If myFlag = False Then
Print #2, VLine
J = J + 1
Else
myFlag = False
K = K + 1
End If
Loop
'
nStop = Timer
Close #1
Close #2
'
MsgBox ("Creato file ZCZC_" & NomeFile & vbCrLf & _
"Record registrati: " & J & vbCrLf & _
"Record eliminati: " & K) & vbCrLf & _
nStop - nStart & " secondi"
'
End Sub
Do While Not EOF(1)
Line Input #1, VLine
VLine2 = UCase(VLine)
For I = 1 To UBound(Cancella)
If InStr(1, VLine2, Cancella(I), vbBinaryCompare) > 1 Then
myFlag = True
Exit For
End If
Next I
If myFlag = False Then
Print #2, VLine
J = J + 1
Else
myFlag = False
K = K + 1
End If
Loop
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 |
Macro che ricerca combinazioni che danno un valore Autore: kar64 |
Forum: Applicazioni Office Windows Risposte: 10 |
Visitano il forum: raimea e 32 ospiti