| | Post: 1 | Registrato il: 27/06/2018
| Città: MILANO | Età: 42 | Utente Junior | 2016 | | OFFLINE | |
|
  27/06/2018 19:09 | |
Ciao a tutti, scusate ma sto sbattendo la testa su questo problema da qualche giorno, ed un po' perché non riesco a metterci tutta l'attenzione che posso ed un po' perché di vba in realtà ne so molto poco, non riesco a capire come risolvere in modo che funzioni correttamente il tutto.
Dunque, sostanzialmente ho una macro con la quale aggiungo in uno stesso foglio un n° di righe che non conosco dove già ce ne sono non so quante.
Con la stessa macro, per ogni riga aggiunta dovrei:
- confrontare le colonne A e B della riga aggiunta con le celle A e B di tutte le altre righe esistenti,
- se ritrovo le stesse A e B in una riga esistente, devo controllare anche le altre colonne della stessa riga,
- nel caso in cui tutte le colonne siano uguali, devo cancellare l'esistente, ma
- nel caso in cui l'esistente abbia le colonne K ed L piene e la nuova no, devo copiare questi valori nella nuova e solo successivamente cancellare la vecchia.
Ora, io ho provato diversi approcci ma non riesco a venirne a capo. Posso chiedere un aiuto?
Questo il mio ultimo tentativo, ma cancella righe che non dovrebbe cancellare, ed in realtà gestisce male la presenza di dati nelle colonne K ed L.
confronta righe 'confronto quella in ultima riga con tutte le precedenti
For r = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
For s = r - 1 To 1 Step -1
If Cells(r, 1).Value = Cells(s, 1).Value And Cells(r, 2).Value = Cells(s, 2).Value Then ' se i valori nella colonna 1 e 2 sono uguali
If Cells(s, 12).Value <> "" And Cells(r, 12).Value = "" Then ' se la cella vecchia è piena e quella nuova no
Cells(r, 12).EntireRow.Delete ' cancello la nuova
' cancello la vecchia se entrambe hanno lo stesso valore o quella nuova è piena
ElseIf Cells(s, 12).Value = Cells(r, 12).Value Or Cells(s, 12).Value = "" And Cells(r, 12).Value <> "" Then
Cells(s, 12).EntireRow.Delete ' cancello la vecchia
Else
' esamina la successiva
End If
End If
Next s
Next r grazie a chi potrà darmi un'idea. ![[SM=g27829]](https://im0.freeforumzone.it/up/0/29/8933109.gif) [Modificato da vorongren01 27/06/2018 19:13] |
|
| | Post: 3.067 | Registrato il: 03/04/2013
| Utente Master | Excel 2000 - 2013 | | OFFLINE | |
|
| 27/06/2018 21:00 | |
Buona sera, verongren01. Per poterti meglio aiutare sarebbe utile che come esempio di ciò che vuoi ottenere allegassi un File, senza Dati sensibili; così possiamo capire nel concreto la tua richiesta. Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013 |
| | Post: 1 | Registrato il: 27/06/2018
| Città: MILANO | Età: 42 | Utente Junior | 2016 | | OFFLINE | |
|
| 28/06/2018 09:41 | |
Ciao Giuseppe,
grazie, spero di essere riuscito ad allegare il file.
L'allegato è giusto un facsimile: devo appendere sotto Foglio1 le righe in Foglio2 (che sono simili, ho solo tolto delle informazioni dalla colonna L). Foglio2 non mi serve a nient'altro che importare i dati utili da un file excel esterno, cosa che al momento funziona correttamente.
Se hanno colonna 1+2 uguali quelle righe si riferiscono certamente allo stesso record. Qualora non le abbiano, non ha senso confrontarle.
Righe con colonna 1+2 uguali possono essere in qualsiasi posizione in entrambi i fogli.
Se queste righe uguali hanno dati diversi sulle altre colonne, si deve tenere quella presa da Foglio2 che è più aggiornata, tranne nel caso in cui in Foglio1 cellaK (Keynum) ci sia un valore evidenziato in giallo (cella originariamente vuota ma compilata a mano).
Nel caso il valore immesso manualmente va preservato con sfondo giallo, tuttavia per le altre colonne va preservato il valore della riga appesa per ultima.
|
| | Post: 3 | Registrato il: 27/06/2018
| Città: MILANO | Età: 42 | Utente Junior | 2016 | | OFFLINE | |
|
| 28/06/2018 15:09 | |
pensavo di aver risolto con il codice seguente ma cancella righe che non deve cancellare.
' analizzo tutte le righe
r = Cells(Rows.Count, 1).End(xlUp).Row
For x = r To 3 Step -1
For y = r - 1 To 2 Step -1
If Cells(x, 1).Value = Cells(y, 1).Value Then
If Cells(x, 2).Value = Cells(y, 2).Value Then
If Cells(x, 12).Value = "" Then
If Cells(y, 12).Value <> "" Then
' copia il valore nella nuova poi cancella la vecchia
Cells(x, 12).Value = Cells(y, 12).Value
Cells(y, 12).EntireRow.Delete
y = y - 1
Else
' cancella la vecchia
Cells(y, 12).EntireRow.Delete
y = y - 1
End If
Else
' cancella la vecchia
Cells(y, 12).EntireRow.Delete
y = y - 1
End If
Else: y = y - 1
End If
Else: y = y - 1
End If
Next y
Next x |
| | Post: 3.565 | Registrato il: 28/06/2011
| Città: AGORDO | Età: 70 | Utente Master | 2013 | | OFFLINE | |
|
| 28/06/2018 16:14 | |
Onestamente non ho capito (hai allegato un file senza VBA + un pezzo di codice incompletto)
Parli del Foglio1 e Foglio2, se le colonna A e B siano uguali
Nel codice vedo che lavori solo su un foglio + due cicli for intrecciati tra loro, dove ogni volta che elimini una riga potrebbero sballare (in più se fossero 10.000 righe sarebbe molto lento)
Potrei provare farlo, però Ti devi spiegare meglio...
>>>tranne nel caso in cui in Foglio1 cellaK (Keynum) ??? Colonna K è tutta vuota
>>>Nel caso il valore immesso manualmente va preservato con sfondo giallo ??? Cioè bisogna colorarla?
Prendo un record del Foglio2, controllo se esiste in Foglio1. Se non esiste lo incollo, se esiste cosa devo controllare? Excel 2013 |
| | Post: 3.068 | Registrato il: 03/04/2013
| Utente Master | Excel 2000 - 2013 | | OFFLINE | |
|
| 28/06/2018 16:33 | |
Buona sera, vorongren01; temo ci siano diverse incongruenze in entrambi i Codici VBA. Non esistono Record che abbiano Valori in Campo "N°ORDINE" (Colonna "A") e in Campo "N°OPZIONE" (Colonna "B") uguali. Quindi, visto che: @vorongren01, scrive:
- confrontare le colonne A e B della riga aggiunta con le celle A e B di tutte le altre righe esistenti,
- se ritrovo le stesse A e B in una riga esistente, devo controllare anche le altre colonne della stessa riga,
...
...
il Codice in Risposta #1 non trova alcuna condizione e non esegue alcuna azione. Il Codice in Risposta #4 è già più coerente ma,le condizioni "Else" eliminano i Record. Quello che posso consigliarti è: - rivedi i Valori inseri in Campo "N°ORDINE" e in Campo "N°OPZIONE" - elimina le Condizioni "Else" Poi possiamo riparlarne. A disposizione. Buona serata. Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013 |
| | Post: 4 | Registrato il: 27/06/2018
| Città: MILANO | Età: 42 | Utente Junior | 2016 | | OFFLINE | |
|
| 28/06/2018 18:06 | |
Ciao,
innanzitutto grazie per il vostro tempo.
Per la spiegazione scusate ma sono un po' confuso e purtroppo non ho il dono della sintesi, come si vede la combo è fatale. Inoltre non posso mettere i file così come sono per i numerosi dati che contengono, ho cercato di allegare qualcosa di funzionante ma ridotto all'osso, spero si capisca lo stesso.
In pratica questo file mi serve per capire quali record hanno il valore della colonna K vuoto, in modo d'andarlo a popolare nel tool relativo.
Da questo tool estraggo un file excel con tutti i record presenti.
Su questo file esterno ho un sacco di colonne inutili, dunque per valutare solo le utili ho risolto creando una macro che copia tutto il contenuto del file esterno, lo incolla su Foglio2 del file in uso, poi da Foglio2 cancella tutte le colonne inutili.
Appendo poi le 14 colonne risultanti al contenuto di Foglio1 e pulisco Foglio2.
A questo punto mi trovo a dover lavorare solo su Foglio1 con tutte le righe presenti.
Un po' lento ma funziona.
E poi mi impappino.
A questo punto dovrei eliminare i doppioni, tenendo:
- una sola riga per ogni record: se il valore in colonna A (es: "BAR123456") e quello in colonna B (es: "10") sono identici in 2 diverse righe, quelle righe si riferiscono allo stesso record;
- i valori vecchi in colonna L e K di ogni record, a meno che quelli vecchi non siano vuoti: in questo caso tengo i nuovi;
- i valori nuovi in tutte le altre colonne di ogni record (non importa cosa contengano).
Una volta depurati i dati eliminando tutti i record multipli, eseguirò altre operazioni sulle varie colonne, tra cui colorare le celle vuote della colonna L in interior.colorindex=6.
Da qui parlavo del colore ma meglio lasciarlo perdere.
Per i doppioni, il file TEST è un esempio che può essere importato più volte, ciascuna delle quali genera dei doppioni che io devo eliminare. I file estratti dal tool non sono sempre identici ma alcune delle loro righe quasi certamente si, altre forse, altre in parte. Importare più volte lo stesso file fornisce un ottimo stress test al funzionamento.
[Modificato da vorongren01 28/06/2018 18:10] |
| | Post: 3.568 | Registrato il: 28/06/2011
| Città: AGORDO | Età: 70 | Utente Master | 2013 | | OFFLINE | |
|
| 29/06/2018 02:14 | |
Un bel VBA, se mi permetti (le variabili si dichiarano tutte) Ex Dim NomeFileConMacro, NomeFileDaAprire As Workbook
Va scritta così Dim NomeFileConMacro As Workbook, NomeFileDaAprire As Workbook
Per mia scelta personale uso Long invece di Integer >>>Dim i As Long, r As Long, c As Long
Sono vecchio e che non ho ancora capito bene le condizioni.
Solo un esempio (sarebbe meglio provarlo sul file che hai allegato oggi con pochi record)
Suggerimento, avvia il codice con F8 ripremendolo per ogni riga (inoltre non eliminare record per adesso).
Come noterai, inserisco una formula sul foglio2, dopo con un ciclo for controllo se ci sono doppioni. EDIT Questo VBA è ideale con i dati messi sui due fogli...Credo che dovrò farci un piccola modifica (in caso che ci siano record nuovi nel foglio2 (non presenti in foglio1)
vb Sub Cerca_Doppioni()
Dim Rg As Object
Dim Ur1 As Long, Ur2 As Long, X As Long, Rr As Long
Dim sh1 As Worksheet: Set sh1 = Worksheets("Foglio1")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Foglio2")
Ur1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
Ur2 = sh2.Range("A" & Rows.Count).End(xlUp).Row
sh2.Range("O2").FormulaR1C1 = "=RC[-14]&RC[-13]"
sh2.Range("O2").Activate
Selection.AutoFill Destination:=Range("O2:O" & Ur2), Type:=xlFillDefault
For X = Ur1 To 2 Step -1
Set Rg = sh2.Range("O2:O" & Ur2).Find(sh1.Cells(X, 1) & sh1.Cells(X, 2), LookIn:=xlValues, LookAt:=xlWhole)
If Not Rg Is Nothing Then
Rr = Rg.Row
If sh1.Cells(X, 11) <> "" Or sh1.Cells(X, 12) <> "" Then
MsgBox "Foglio1, la riga " & X & " contiene dei dati, cosa devo fare? Per terminare CTRL+ALT+Pause"
'esempio se devo copiare/eliminare la riga del foglio2
'sh2.Range(sh2.Cells(Rr, 1), sh2.Cells(Rr, 14)).Copy
'sh2.Cells(Rr, 1).EntireRow.Delete
Else
MsgBox "Foglio1, la riga " & X & " NON contiene dati, cosa devo fare? Per terminare CTRL+ALT+Pause"
'esempio se devo incollare la riga sul foglio1
'sh2.Range(sh2.Cells(Rr, 1), sh2.Cells(Rr, 14)).Copy
'sh1.Cells(X, 1).PasteSpecial
End If
End If
Next X
Set sh1 = Nothing
Set sh2 = Nothing
Set Rg = Nothing
End Sub
[Modificato da raffaele1953 29/06/2018 10:22] Excel 2013 |
| | Post: 3.070 | Registrato il: 03/04/2013
| Utente Master | Excel 2000 - 2013 | | OFFLINE | |
|
| 29/06/2018 08:40 | |
Buona giornata, vorongren01. Perdonami, continuo a non capire  ; ti chiedo una cortesia, potresti indicarmi quali sono i Record che hanno Valori uguali in Campo "RIF_CAMPAGNA" (Colonna "A") e in Campo "RIF_OPZIONE" (Colonna "B")? Grazie dell'attenzione che potrai dedicarmi per la tua cortese risposta. A disposizione. Buon Lavoro. Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013 |
| | Post: 5 | Registrato il: 27/06/2018
| Città: MILANO | Età: 42 | Utente Junior | 2016 | | OFFLINE | |
|
| 29/06/2018 09:19 | |
GiuseppeMN, 29/06/2018 08.40:
... potresti indicarmi quali sono i Record che hanno Valori uguali in Campo "RIF_CAMPAGNA" (Colonna "A") e in Campo "RIF_OPZIONE" (Colonna "B")?...
Ciao Giuseppe, di partenza non ci sono righe doppie, si creano nel momento in cui importi più volte il file esterno. Importarlo più volte simula l'importazione di file in più giorni successivi, ad ogni importazione Foglio1 non si resetta ma rimane con i dati depurati caricati con l'ultima importazione. Raffaele grazie per la risposta e i suggerimenti, appena possibile provo a metterli in pratica. Vi faccio sapere. |
| | Post: 6 | Registrato il: 27/06/2018
| Città: MILANO | Età: 42 | Utente Junior | 2016 | | OFFLINE | |
|
| 02/07/2018 14:13 | |
Ciao ragazzi scusate se non mi sono fatto più sentire ma ci ho lavorato su, l'esempio di Raffaele non ha risolto ma mi ha dato delle idee che ho provato a sviluppare. Ho buttato via tutto un paio di volte poi mi sono risolto a fare tutto su più cicli For in modo da non incasinarmi troppo.
Sotto trovate la macro in versione "released", non è né bella, né elegante, ma fa il suo sporco lavoro in un tempo accettabile.
Se volete provare a darci un occhiata e vedere se è possibile ottimizzarla è cosa buona e giusta.
nb: per confrontare le colonne A+B ho trasformato il contenuto di ciascuna in String, le concateno e le confronto, invece che concatenare più celle o confrontare più range.
Solamente nel caso in cui queste sono uguali esamino la colonna L: se quella nuova (= appesa per ultima quindi che analizzo per prima) sia vuota e quella vecchia piena, prendo il valore della vecchia e lo copio nella nuova.
Dopo cancello tutte le righe doppie più vecchie a prescindere, così sono certo che tutti gli altri dati siano aggiornati e che le righe non doppie mi rimangono sicuramente.
ps: dato che il file è condiviso, per far girare la mail lo tolgo dalla condivisione, tolgo la protezione celle, e alla fine rimetto entrambi.
Sub Carica()
' toglie il file dalla condivisione e protezione foglio in modo da permettere il 100% delle funzioni successive
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveWorkbook.ExclusiveAccess
Worksheets("Foglio1").Unprotect
Dim NomeFileConMacro As Workbook, NomeFileDaAprire As Workbook
Dim Ret1
Dim titolo As String, rigaBase As String, rigaConfr As String
Dim i As Long, r As Long, c As Long ' contatore, n° riga e colonna
Dim rng As range, rCell As range, delRange As range, mvRange As range
Dim sh1 As Worksheet: Set sh1 = Worksheets("Foglio1")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Foglio2")
Set NomeFileConMacro = ActiveWorkbook
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , "Selezionare il file")
If Ret1 = False Then
' nel caso non venga selezionato nessun file, ripristino la condivisione del file e lo riproteggo
Worksheets("Foglio1").range("$A:$M").Locked = True
Worksheets("Foglio1").range("$H:$I").Locked = False
Worksheets("Foglio1").Protect UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowFiltering:=True, AllowSorting:=True
ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.FullName, AccessMode:=xlShared
ActiveWorkbook.KeepChangeHistory = True
Application.DisplayAlerts = True
Exit Sub
End If
Set NomeFileDaAprire = Workbooks.Open(Ret1)
NomeFileDaAprire.Sheets(1).Cells.Copy NomeFileConMacro.Sheets(2).Cells
NomeFileDaAprire.Close SaveChanges:=False
Set NomeFileDaAprire = Nothing
sh2.Activate
With Selection
' cancello le colonne vuote
c = Cells(1, Columns.Count).End(xlToLeft).Column
Set rng = range(Cells(1, 1), Cells(1, c))
For Each rCell In rng
If rCell.Value = "" Then rCell.EntireColumn.Delete
Next rCell
' cancello le prime 3 righe inutili
For r = 3 To 1 Step -1
Cells(r, 1).EntireRow.Delete
Next r
'cancello le colonne inutili del file importato
For c = Cells(1, Cells.Columns.Count).End(xlToLeft).Column To 1 Step -1
titolo = UCase(Trim(CStr(Cells(1, c).Value)))
titolo = Replace(titolo, Chr(34), "") 'tolgo eventuali "
titolo = Replace(titolo, vbLf, "") 'tolto eventuali a capo
Select Case Trim(UCase(titolo)) 'tolgo eventuali spazi
Case "DATA_CREAZIONE", "DESCRIZIONE_OPZIONE", "AUDIENCE_PROFILE_NAME", "INSTALMENT_PLAN", "COMMERCIAL KEY NUMBER", "RIF_CAMPAGNA", "RIF_OPZIONE", "CLIENTE", "PRODOTTO_1", "OPTION_STATUS_NAME", "DATA_INIZIO", "DATA_FINE", "DURATION", "DURATION_COMM_KEY"
' lasciale
Case Else 'altrimenti raggruppale e cancellale
If delRange Is Nothing Then
Set delRange = Columns(c)
Else
Set delRange = Uni0n(delRange, Columns(c))
End If
End Select
Next c
If Not delRange Is Nothing Then delRange.Delete
'appendo foglio2 sotto foglio1 a prescindere dai doppioni
c = sh2.Cells(1, Cells.Columns.Count).End(xlToLeft).Column ' n° ultima colonna sh2
r = sh2.Cells(Rows.Count, 1).End(xlUp).Row ' n° ultima riga sh2
Set rng = sh2.range(Cells(1, 1), Cells(r, c)) ' seleziona tutta la riga
rng.Cut
sh1.Cells(sh1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).EntireRow.Insert Shift:=xlDown
End With ' termina sheets(2).activate
' SISTEMO IL FOGLIO UTILE
Sheets(1).Activate
With Selection
r = Cells(Rows.Count, 1).End(xlUp).Row ' n° ultima riga sh1
' trovo le righe da cancellare perché doppie o con dati non aggiornati
For i = r To 1 Step -1
rigaBase = CStr(Cells(i, 1).Value) + CStr(Cells(i, 2).Value) ' considero il contenuto delle prime 2 colonne tutto insieme
For j = i - 1 To 1 Step -1
rigaConfr = CStr(Cells(j, 1).Value) + CStr(Cells(j, 2).Value)
If rigaBase = rigaConfr Then ' se la stringa data dalla somma di A e B è uguale
If Cells(i, 12).Value = "" And Cells(j, 12).Value <> Cells(i, 12).Value Then
' controllo i valori in K e L
' se nella nuova è vuoto E diverso dalla vecchia tengo il valore vecchio
Cells(j, 12).Interior.ColorIndex = 1 ' da cancellare
Cells(i, 12).Interior.ColorIndex = 6 ' evidenziala
Cells(i, 11).Interior.ColorIndex = 6 ' evidenziala
Cells(i, 12).Value = Cells(j, 12).Value
Cells(i, 11).Value = Cells(j, 11).Value ' la col K sarà sempre da riportare perché non è mai piena nell'estrazione
Else ' altrimenti tengo il nuovo
Cells(j, 12).Interior.ColorIndex = 1 ' da cancellare
End If
End If
Next j
Next i
' cancello le righe inutili come trovate in precedenza = se nere
r = Cells(Rows.Count, 1).End(xlUp).Row ' n° ultima riga sh1
For i = r To 1 Step -1
If Cells(i, "L").Interior.ColorIndex = 1 Then
Cells(i, "L").EntireRow.Delete
End If
Next i
' inserisco ulteriore formattazione utile in base allo stato campagna
For r = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 ' controllo tutte le righe
Select Case Trim(CStr(LCase(Cells(r, 9).Value))) ' analizzo lo stato campagna
Case "cancelled" ' se cancellata eliminala
Cells(r, 9).EntireRow.Delete
Case "published" ' se pubblicata eliminala se terminata
DATA_FINE = Cells(r, 7).Value
If Day(DATA_FINE) < Day(Now) - 1 Then
Cells(r, 7).EntireRow.Delete
ElseIf Month(DATA_FINE) < Month(Now) Then
Cells(r, 7).EntireRow.Delete
ElseIf Year(DATA_FINE) < Year(Now) Then
Cells(r, 7).EntireRow.Delete
End If
Case "in preparation" ' se da gestire evidenziala
If Cells(r, 12).Value = "" Then
Cells(r, 12).Interior.ColorIndex = 6
Cells(r, 11).Interior.ColorIndex = 6
End If
' cerca anche se i secondaggi non collimano se la colN è piena
Cells(r, 13).Value = CInt(Cells(r, 13).Value)
Cells(r, 14).Value = CInt(Cells(r, 14).Value)
If Cells(r, 13).Value <> "" And Cells(r, 14).Value <> "" And Cells(r, 13).Value <> "0" And Cells(r, 14).Value <> "0" And Cells(r, 13).Value <> Cells(r, 14).Value Then
Cells(r, 13).Select
With Selection
.Interior.ColorIndex = 3
.Font.Bold = True
.Font.ColorIndex = 6
End With
Cells(r, 14).Select
With Selection
.Interior.ColorIndex = 3
.Font.Bold = True
.Font.ColorIndex = 6
End With
End If
' negli altri stati possibili evidenziala come allarme
Case "publishing", "amend", "to be cancelled"
With Cells(r, 9)
.Interior.ColorIndex = 3
.Font.Bold = True
.Font.ColorIndex = 6
End With
Case Else ' in qualsiasi altra situazione (es: è il titolo)
' non modificare nulla
End Select
Next r
' sistemo la grandezza delle celle
Cells.EntireColumn.ColumnWidth = 20
Cells.EntireRow.AutoFit
' inserisco giorno e ora dell'ultima volta che ha girato la macro
If Cells(1, 1).Value <> "Aggiornato il:" Then
Cells(1, 1).Value = "Aggiornato il:"
End If
Cells(1, 2).Value = Format(Now, "dd/mmm/yyyy hh:mm")
Cells(1, 2).Font.Bold = True
' inserisco i filtri e ordino le righe in base alla data d'inizio
If Not ActiveSheet.AutoFilterMode Then
ActiveSheet.range("A1").AutoFilter
End If
Worksheets("Foglio1").AutoFilter.Sort.SortFields.Clear
Worksheets("Foglio1").AutoFilter.Sort.SortFields.Add Key:=range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Worksheets("Foglio1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'rinomino la colonna inutile come "Note Traffic" dato che esiste solo per questo
If Cells(2, 11).Value <> "NOTE_TRAFFIC" Then Cells(2, 11).Value = "NOTE_TRAFFIC"
End With ' termina sheets(1).activate
' proteggo nuovamente il foglio
Worksheets("Foglio1").range("$A:$N").Locked = True
Worksheets("Foglio1").range("$K:$L").Locked = False
Worksheets("Foglio1").Protect UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowFiltering:=True, AllowSorting:=True
' rimetto il file in condivisione
ActiveWorkbook.KeepChangeHistory = True
ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.FullName, AccessMode:=xlShared
MsgBox ("Importazione Controllo Booking Adsmart completata.")
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
|
| | Post: 3.578 | Registrato il: 28/06/2011
| Città: AGORDO | Età: 70 | Utente Master | 2013 | | OFFLINE | |
|
| 03/07/2018 00:03 | |
In alto, prima di Sub Carica() metti:
Option Explicit 'verifica che ci siano tutte le variabili
Option Compare Text 'esegui confrontando sia minuscole che maiuscole
Ti manca la Dim j As Long
Ti manca la Dim DATA_FINE As Date
Hai scritto Uni0n con lo Zero
Se scrivi Set rng = sh2.Range(Cells(1, 1), Cells(r, c)) meglio che sia... sh2.Range(sh2.Cells(1, 1), sh2.Cells(r, c))
Per tutti i Set, alla fine prima di End sub metti
Set rng = Nothing
Set delRange = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
Ps. Mi sono piaciute le righe sulla Condivizione??? Mà non riuscivo più ad entrare nel VBA. Premo bottore "errore senza dirmi il motivo"
Se a Te va bene così, meglio. Complimenti bel lavoro
NB. Piccolo dettaglio, se usi:
Dim sh1 As Worksheet: Set sh1 = Worksheets("Foglio1")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Foglio2")
Non servono più i vari sh2.Activate, basta mettere davanti ad ogni riga sh2. o sh1. (lo lo uso come promemoria per quando scrivo, da "quale foglio" in "altro foglio" sicuro di non sbagliare)
sh1.Range("$A:$M").Locked = True ed ...sh1.AutoFilter.Sort.SortFields.Clear
Excel 2013 |
| | Post: 7 | Registrato il: 27/06/2018
| Città: MILANO | Età: 42 | Utente Junior | 2016 | | OFFLINE | |
|
| 03/07/2018 08:07 | |
raffaele1953, 03/07/2018 00.03:
In alto, prima di Sub Carica() metti:
Option Explicit 'verifica che ci siano tutte le variabili
Option Compare Text 'esegui confrontando sia minuscole che maiuscole
Ti manca la Dim j As Long
Ti manca la Dim DATA_FINE As Date
Hai scritto Uni0n con lo Zero
Se scrivi Set rng = sh2.Range(Cells(1, 1), Cells(r, c)) meglio che sia... sh2.Range(sh2.Cells(1, 1), sh2.Cells(r, c))
Per tutti i Set, alla fine prima di End sub metti
Set rng = Nothing
Set delRange = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
Ps. Mi sono piaciute le righe sulla Condivizione??? Mà non riuscivo più ad entrare nel VBA. Premo bottore "errore senza dirmi il motivo"
Se a Te va bene così, meglio. Complimenti bel lavoro
NB. Piccolo dettaglio, se usi:
Dim sh1 As Worksheet: Set sh1 = Worksheets("Foglio1")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Foglio2")
Non servono più i vari sh2.Activate, basta mettere davanti ad ogni riga sh2. o sh1. (lo lo uso come promemoria per quando scrivo, da "quale foglio" in "altro foglio" sicuro di non sbagliare)
sh1.Range("$A:$M").Locked = True ed ...sh1.AutoFilter.Sort.SortFields.Clear
Ciao Raffaele, grazie mille dei suggerimenti, ho provveduto alle modifiche.
Per l'errore di cui parli ne sono a conoscenza e ci ho sbattuto la testa diverse volte.
Da quel che ho capito si tratta di un blocco che hanno i file condivisi e non ci si può fare molto.
In effetti ogni volta che devo modificare il codice ora come ora tolgo il file dalla condivisione, modifico e poi ricondivido (che è un po' quello che faccio fare alla macro per permetterle di cancellare le righe, altra operazione non permessa sui file condivisi).
|
| | Post: 3.582 | Registrato il: 28/06/2011
| Città: AGORDO | Età: 70 | Utente Master | 2013 | | OFFLINE | |
|
| 03/07/2018 11:08 | |
Secondo me l'errore è dovuto al fatto che in alto "quando" togli la condivizione dovrebbe apparirTi una finestrella con una scelta si/no (nella quale devi rispondere si). Dato che hai messo >>>DisplayAlerts = False, "questa" non appare è Tu non gli dai la risposta. Io proverei a dividere il Codice...in tre pezzi
Sub prova()
Call togli_condivizione (senza DisplayAlerts), oppure trova il modo di dargli la risposta SI
Call Carica
Call Rimetti_condivizione
End sub [Modificato da raffaele1953 03/07/2018 11:09] Excel 2013 |
| | Post: 8 | Registrato il: 27/06/2018
| Città: MILANO | Età: 42 | Utente Junior | 2016 | | OFFLINE | |
|
| 03/07/2018 11:44 | |
Non ho capito: quando è condiviso è vero che non fa accedere al VBA (la finestra ALT+F11 per intenderci) ma la macro funziona correttamente... significa che lui dalla condivisione il file lo toglie e poi lo rimette correttamente. |
| | Post: 3.584 | Registrato il: 28/06/2011
| Città: AGORDO | Età: 70 | Utente Master | 2013 | | OFFLINE | |
|
| 03/07/2018 15:21 | |
A me la riga ActiveWorkbook.ExclusiveAccess da errore ??? Non capisco il motivo (forse differenza con excel2016)?
Ho sbagliato riguardo la condivizione, avevo inserito il nuovo codice e provato (mi era sembrato OK), però non vedevo più il codice. Allora ho premuto il bottone (che però era ancora collegato alla sub test2). Sicuramente l'errore è accaduto per questo motivo. Riprovato adesso e tutto OK con la riga ExclusiveAccess disabilitata.
Ultimo particolare, volevo aggiungere queste due righe:
Application.Calculation = xlCalculationManual 'inizio
Application.Calculation = xlCalculationAutomatic 'fine
Per verificare se fosse più veloce e mi sono trovato davanti ad un dilemma...
In alto disattivi il DisplayAlerts+ScreenUpdating
Subito sotto >>>If Ret1 = False Then
Nel quale rimetti a posto il tutto ed esci (manca il ScreenUpdating)
Secondo me al posto di Exit Sub >>> Goto Fine ed in basso dopo il MSGBOX
Fine:
Qui ripristini DisplayAlerts+ScreenUpdating e "spegni" tutti i SET attivi Excel 2013 |
| | Post: 9 | Registrato il: 27/06/2018
| Città: MILANO | Età: 42 | Utente Junior | 2016 | | OFFLINE | |
|
| 03/07/2018 21:35 | |
raffaele1953, 03/07/2018 15.21:
A me la riga ActiveWorkbook.ExclusiveAccess da errore ??? Non capisco il motivo (forse differenza con excel2016)?
Ho sbagliato riguardo la condivizione, avevo inserito il nuovo codice e provato (mi era sembrato OK), però non vedevo più il codice. Allora ho premuto il bottone (che però era ancora collegato alla sub test2). Sicuramente l'errore è accaduto per questo motivo. Riprovato adesso e tutto OK con la riga ExclusiveAccess disabilitata.
Ultimo particolare, volevo aggiungere queste due righe:
Application.Calculation = xlCalculationManual 'inizio
Application.Calculation = xlCalculationAutomatic 'fine
Per verificare se fosse più veloce e mi sono trovato davanti ad un dilemma...
In alto disattivi il DisplayAlerts+ScreenUpdating
Subito sotto >>>If Ret1 = False Then
Nel quale rimetti a posto il tutto ed esci (manca il ScreenUpdating)
Secondo me al posto di Exit Sub >>> Goto Fine ed in basso dopo il MSGBOX
Fine:
Qui ripristini DisplayAlerts+ScreenUpdating e "spegni" tutti i SET attivi
Ciao, si rimetto tutto a posto prima di uscire, in effetti potrei usare il goto e verrebbe tutto più pulito e forse più veloce... lo avevo evitato perché avevo letto in giro che è un metodo che si tende ad evitare. Vediamo come viene dopo che ho fatto questa modifica :)
|
|
|
|
|