Estrazione celle da piu file nella stessa cartella

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

FROST220684 ha scritto:

quindi tu dici che il codice postato nel #36617:

Dovrebbe essere così, con la correzione del post #36625.

Il codice postato nella mia risposta #36625 è il tentativo di correggere l'errore di cui alla tua immagine, che non è dovuto a wb2: stranamente, se nel file non ci sono collegamenti attivi l'insieme LinkSources è una stringa vuota altrimenti diventa una collezione di links e questo non riesco a capire come hanno fatto a pensare una cosa simile quelli di Microsoft, fatto sta che rompe il codice e serve il workaround con la gestione dell'errore.

FROST220684 ha scritto:

alla fine dell'estrapolazione è spostare tutti i file in una sottocartella "File Gia' Esportati"

...e questo è un altro discorso 🙂
Si potrebbe provare a usare SaveCopyAs.

Prima del primo .Close False e prima del secondo .Close True:

.SaveCopyAs "C:\Users\anna\Desktop\file esportati\" & .Name

dovrebbe riuscire a salvare una copia di tutti i file in una cartella di destinazione. 

[FROST220684Partecipante FROST220684]

Ma invece di copiare non si può solo spostare tipo taglia e incolla?

cmq secondo me ci stiamo incartando io utilizzo codici separati il primo che è questo lo uso per eliminare i collegamenti dai preventivi vecchi perchè ormai i nuovi escono senza collegamenti perchè ho modificato proprio il file preventivi salva excelpdf

Sub OperaInDirectory()
Dim v As Variant
Dim wb1 As Workbook
Dim sFileName As String

Const MYFOLDER = "C:\Users\franz\Desktop\Nuova cartella\"

    On Error GoTo gest_err
    
    Set wb1 = ThisWorkbook
    sFileName = Dir(MYFOLDER & "*.xlsx")
    
    Do While Len(sFileName) > 0
        Workbooks.Open Filename:=MYFOLDER & sFileName

        With ActiveWorkbook
            If .LinkSources(Type:=xlLinkTypeExcelLinks) = "" Then
                .Close False
            End If
        End With
resume_here:
        sFileName = Dir
    Loop
    
    Exit Sub

gest_err:
    With ActiveWorkbook
        For Each v In .LinkSources(Type:=xlLinkTypeExcelLinks)
            .BreakLink Name:=v, Type:=xlLinkTypeExcelLinks
        Next
        .Close True
    End With
    Resume resume_here
    
End Sub

il secondo che mi serve ad estrapolare i dati dai preventivi già privi di collegamenti è questo

`option explicit 

Sub file_riassuntivo()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim percorso As String
    Dim nomeFile As String
    Dim WB As Workbook
    Dim sh As Worksheet
    percorso = "C:\Users\Anna\Desktop\Preventivi Excel\Nuova cartella\"
    nomeFile = Dir(percorso)
    Do While nomeFile <> ""
        If nomeFile <> ThisWorkbook.Name Then
            Set WB = Application.Workbooks.Open(percorso & nomeFile)
            Set sh = WB.Worksheets(1)
            sh.Range("B1:B11").Copy
            ThisWorkbook.Sheets(1).Activate
            uR = Cells(Rows.Count, 1).End(xlUp).Row + 1
            If Cells(2, 1) = 1 Then
                Cells(uR, 1) = Cells(uR - 1, 1) + 1
            Else
                Cells(2, 1) = 1
            End If
            Cells(uR, 2).PasteSpecial Paste:=xlValues, Transpose:=True
            WB.Close False
        End If
        nomeFile = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Dati Importati.", vbInformation, "OK"
    
End Sub
`

e su quest'ultimo codice che va aggiunto il tagli ed incolla dei file appena esportati in un altra cartella.

 

cmq sto ti sto facendo impazzire nello spiegare. abbiamo fatto cose molto più complicate e secondo me ci stiamo perdendo nei vari post   

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Pensavo che sarebbe stato meglio fare tutto in una sola procedura comunque per spostare file da una cartella all'altra puoi cavartela con molto poco; un piccolo file bat con questo contenuto:

move "c:\users\anna\desktop\cartella di partenza"\*.xlsx "c:\users\anna\desktop\cartella di destinazione"

 

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Se ti sembra più elegante in un pezzetto di codice VBA allora è così:

Sub sposta_files()
Dim s As String
Const folder_from = "C:\Users\anna\Desktop\cartella di partenza\*.xlsx"
Const folder_to = "C:\Users\anna\Desktop\cartella di destinazione"

    s = "cmd.exe /c move /Y ""%1"" ""%2"""
    s = Replace(s, "%1", folder_from)
    s = Replace(s, "%2", folder_to)
 
End Sub

[FROST220684Partecipante FROST220684]

Sub esportaemuovi()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim s As String
    Dim percorso As String
    Dim nomeFile As String
    Dim WB As Workbook
    Dim sh As Worksheet
    percorso = "C:\Users\Anna\Desktop\Preventivi Excel\"
    nomeFile = Dir(percorso)
    Do While nomeFile <> ""
        If nomeFile <> ThisWorkbook.Name Then
            Set WB = Application.Workbooks.Open(percorso & nomeFile)
            Set sh = WB.Worksheets(1)
            sh.Range("B1:B11").Copy
            ThisWorkbook.Sheets(1).Activate
            uR = Cells(Rows.Count, 1).End(xlUp).Row + 1
            If Cells(2, 1) = 1 Then
                Cells(uR, 1) = Cells(uR - 1, 1) + 1
            Else
                Cells(2, 1) = 1
            End If
            Cells(uR, 2).PasteSpecial Paste:=xlValues, Transpose:=True
            WB.Close False
        End If
        nomeFile = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Const folder_from = "C:\Users\Anna\Desktop\Preventivi Excel\*.xlsx"
Const folder_to = "C:\Users\Anna\Desktop\Preventivi Excel\Nuova cartella"

    s = "cmd.exe /c move /Y ""%1"" ""%2"""
    s = Replace(s, "%1", folder_from)
    s = Replace(s, "%2", folder_to)
    MsgBox "Dati Importati e File Spostati.", vbInformation, "OK"
    
End Sub

allora io ho integrato cosi non capisco dove sia il problema.

la parte "Dim s As String" l'ho spostata sopra insieme a tutte le altre (ho anche provato a metterla alla fine perchè mi era venuto il dubbio di fare una cavolata ma anche li niente) ed ho aggiunto il resto del codice nella parte finale. la macro funziona esporta i dati e tutti ma i file non vengono spostati  

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

FROST220684 ha scritto:

la parte "Dim s As String" l'ho spostata sopra insieme a tutte le altre

Hai fatto benissimo, si chiama "dichiarazione di variabili" e può andare dovunque nel codice (naturalmente prima di utilizzare la variabile!) ma è preferibile in cima alla routine per chiarezza e leggibilità. Tecnicamente anche le due Const sono variabili (costanti, ma sono variabili 🙂 ) e andrebbero in cima alla routine, prima dell'inizio del codice vero e proprio.

Sul fatto che non funzioni lo spostamento dei file, è strano. Il pezzetto di codice isolato (cioè la routine "sposta_files" di cui sopra) ti funziona, spostando i file da una cartella all'altra, o no? Hai controllato che dentro "Preventivi Excel" esista la cartella "Nuova cartella"? altrimenti verifica bene i percorsi. Può darsi che nei miei test abbia messo queste cartelle ma era solo per test, tu devi aggiustarle in base alla realtà del tuo sistema.

[FROST220684Partecipante FROST220684]

vecchio frac ha scritto:

Il pezzetto di codice isolato (cioè la routine "sposta_files" di cui sopra) ti funziona

era l'unica prova che non avevo fatto per dimenticanza. no in effetti non funziona non da errori nel senso che la esegue normalmente ma non va in porto. i percorsi sono corretti anche perchè li prendo direttamente dalla barra risorse. non so davvero vecchio frac. a te funziona? ti allego file dove si vede che sul file excel ha esportato i dati ma nelle cartelle non è successo nulla. si vede anche il percorso. allego il codice vba utilizzato

Sub esportaemuovi()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim s As String
    Const folder_from = "C:\Users\Anna\Desktop\Preventivi Excel\*.xlsx"
Const folder_to = "C:\Users\Anna\Desktop\Preventivi Excel\Nuova cartella"
    Dim percorso As String
    Dim nomeFile As String
    Dim WB As Workbook
    Dim sh As Worksheet
    percorso = "C:\Users\Anna\Desktop\Preventivi Excel\"
    nomeFile = Dir(percorso)
    Do While nomeFile <> ""
        If nomeFile <> ThisWorkbook.Name Then
            Set WB = Application.Workbooks.Open(percorso & nomeFile)
            Set sh = WB.Worksheets(1)
            sh.Range("B1:B11").Copy
            ThisWorkbook.Sheets(1).Activate
            uR = Cells(Rows.Count, 1).End(xlUp).Row + 1
            If Cells(2, 1) = 1 Then
                Cells(uR, 1) = Cells(uR - 1, 1) + 1
            Else
                Cells(2, 1) = 1
            End If
            Cells(uR, 2).PasteSpecial Paste:=xlValues, Transpose:=True
            WB.Close False
        End If
        nomeFile = Dir
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    

    s = "cmd.exe /c move /Y ""%1"" ""%2"""
    s = Replace(s, "%1", folder_from)
    s = Replace(s, "%2", folder_to)
    MsgBox "Dati Importati e File Spostati.", vbInformation, "OK"
    
End Sub

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Oh Santa Polenta!!!

Ho dimenticato di darti l'istruzione di Shell che deve eseguire la stringa s ...     
Sei autorizzato a darmi del rincojonito da oggi per venti anni 😀

    s = "cmd.exe /c move /Y ""%1"" ""%2"""
    s = Replace(s, "%1", folder_from)
    s = Replace(s, "%2", folder_to)
   
    'questa istruzione esegue il comando di spostamento.
    Shell s
    
    MsgBox "Dati Importati e File Spostati.", vbInformation, "OK"
    
End Sub

 

[FROST220684Partecipante FROST220684]

non mi potrei mai permettere con tutto l'aiuto che mi dai e che ci dai ci prostiamo davanti al tuo genio   

grazie mille funziona tutto. dovrebbe essere ultimato  (l'ho detto anche una settimana fa)  

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

FROST220684 ha scritto:

ci prostiamo

Manca una erre... sai, altrimenti alla mia età uno pensa subito alla prostata   

FROST220684 ha scritto:

dovrebbe essere ultimato  (l'ho detto anche una settimana fa)

Fai test approfonditi e se c'è qualcosa che non va lo rivediamo insieme.

[FROST220684Partecipante FROST220684]

vecchio frac ha scritto:

Manca una erre... sai, altrimenti alla mia età uno pensa subito alla prostata   

ahhahahahahhahahahhaha siamo alla frutta

vecchio frac ha scritto:

Fai test approfonditi e se c'è qualcosa che non va lo rivediamo insieme.

grazie mille come sempre alla prossima

[FROST220684Partecipante FROST220684]

sto utilizzando la macro elimina collegamenti che funziona bene ma su alcuni file mi chiede cmq di aggiornare i collegamenti non facendolo in automatico. ti allego il file macro ed un preventivo su cui mi da il problema. secondo me è un problema derivante dall'origine del collegamento che è diversa da quella inserita in macro. ho provato a modificarla ma niente. ti allego anche vba. secondo te cosa c'è che non va mi da il problema solo su questa tipologia di file su altri 1000 no.

Sub OperaInDirectory()
Dim v As Variant
Dim wb1 As Workbook
Dim sFileName As String

Const MYFOLDER = "C:\Users\Anna\Desktop\PREVENTIVI FABIO\"

    On Error GoTo gest_err
    
    Set wb1 = ThisWorkbook
    sFileName = Dir(MYFOLDER & "*.xlsx")
    
    Do While Len(sFileName) > 0
        Workbooks.Open Filename:=MYFOLDER & sFileName

        With ActiveWorkbook
            If .LinkSources(Type:=xlLinkTypeExcelLinks) = "" Then
                .Close False
            End If
        End With
resume_here:
        sFileName = Dir
    Loop
    
    Exit Sub

gest_err:
    With ActiveWorkbook
        For Each v In .LinkSources(Type:=xlLinkTypeExcelLinks)
            .BreakLink Name:=v, Type:=xlLinkTypeExcelLinks
        Next
        .Close True
    End With
    Resume resume_here
    
End Sub

Allegati:

You must be logged in to view attached files.

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Il punto è che non si riesce ad eliminare l'avviso nemmeno con DisplayAlerts impostato a False. Per il resto il codice, quando deve eliminare il collegamento, lo fa e salva il file, poi riaprendolo i collegamenti non ci sono più.

[FROST220684Partecipante FROST220684]

mi mancano 1656 preventivi cosi farli manuali è impossibile   ma funzionava io non vorrei perchè me li ha passati un mio collega e lui li ha creati tramite il salva excel ma da una posizione diversa del suo pc e sulla mia magari non funziona questa cosa l'ho pensato perchè registrando una macro su un file lui mi da questo codice

ActiveWorkbook.BreakLink Name:="C:\Users\spada\Desktop\PREVENTIVI VBA.xlsm", _
        Type:=xlExcelLinks

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Temo che sia ineliminabile il fatto di dover fare clic su uno dei pulsanti dell'avviso automatico (meglio scegliere "non aggiornare" perchè è più rapido). In ogni caso il link viene poi interrotto. L'avviso automatico non si può intercettare neanche con DisplayAlerts impostato su False.

[rollis13Partecipante rollis13 Karma: 8 pts]

Un saluto a tutti.

Spulciando i miei appunti ho trovato che se cambi la riga dell' 'Open' come ti riporto qui sotto non avrai la segnalazione dei collegamenti mancanti (qualche test l'ho fatto col file che hai allegato al post #36683). Purtroppo l'appunto è datato è ridotto all'osso ma forse in rete si trovano spiegazioni sull'uso di Updatelinks:=0.

Workbooks.Open Filename:=MyFolder & sFileName, UpdateLinks:=0

Ps. un cenno lo trovi qui: LINK 

[FROST220684Partecipante FROST220684]

vecchio frac ha scritto:

Temo che sia ineliminabile il fatto di dover fare clic su uno dei pulsanti dell'avviso automatico (meglio scegliere "non aggiornare" perchè è più rapido). In ogni caso il link viene poi interrotto. L'avviso automatico non si può intercettare neanche con DisplayAlerts impostato su False.

rollis13 ha scritto:

Workbooks.Open Filename:=MyFolder & sFileName, UpdateLinks:=0

io purtroppo non ho le conoscenze per gestirlo vecchio frac suggerimenti?

[FROST220684Partecipante FROST220684]

allora io ho provato a sostituirlo e con mio sommo piacere sembra funzionare ho provato su un file dove c'erano i collegamenti e dopo la macro i collegamenti non c'erano più. quindi ti ringrazio

rollis13 ha scritto:

Workbooks.Open Filename:=MyFolder & sFileName, UpdateLinks:=0

e ringrazio naturalmente vecchio frac che ci prova sempre.

vi aggiornero e spero che tutto fili liscio

 

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

FROST220684 ha scritto:

e ringrazio naturalmente vecchio frac che ci prova sempre.

Ma veramente stavolta il merito è totalmente di rollis13   

rollis13 ha scritto:

Spulciando i miei appunti

[rollis13Partecipante rollis13 Karma: 8 pts]

Gli appunti sono una mia vecchia abitudine, a lavoro li chiamavo 'i miei vangeli' . Il guaio è che ora col passare degli anni devo mettere un appunto per ricordare dove sono gli appunti .

[FROST220684Partecipante FROST220684]

ciao a tutti,

ultima necessita. all'interno del file allegato ci sono delle righe con dei valori duplicati nelle colonne E ed F. La necessità è quella di creare un nuovo foglio aggiuntivo che esporti solo le righe dove trova almeno 1 duplicato nelle 2 colonne saltando alla successiva. ho provato a cercare su internet ma i post riguardano solo l'eliminazione dei duplicati a me serve conservarli sul foglio originale ed avere un foglio con solo quelle righe.

grazie a tutti per l'aiuto

Allegati:

You must be logged in to view attached files.

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Sul file che hai inviato ho provato questo codice e sembra funzionare 🙂
Sarò poi smentito sul campo, come mi succede sempre 😉

Option Explicit

Sub find_and_store_duplicates()
Dim r As Range
Dim ce As Range
Dim i As Integer
Dim j As Long

    j = Application.CountA(Worksheets("Database Duplicati").Range("A:A"))
    With Worksheets("Database")
        Set r = .Range("A1").CurrentRegion
        Set r = r.Resize(r.Rows.Count - 1, 1).Offset(1, 4)
        
        'analizza la colonna E del foglio database e inserisce i duplicati nel secondo foglio
        For Each ce In r
            i = Application.CountIf(r, ce)
            If i > 1 Then
                j = j + 1
                ce.EntireRow.Copy Worksheets("Database Duplicati").Cells(j, 1)
            End If
        Next
    
        'analizza la colonna F del foglio database e inserisce i duplicati nel secondo foglio
        'se non sono già stati ricopiati dal ciclo precedente
        Set r = r.Offset(, 1)
        For Each ce In r
            i = Application.CountIf(r, ce)
            If i > 1 Then
                If Worksheets("Database Duplicati").Range("A:A").Find(ce.Offset(, -5), LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then
                    j = j + 1
                    ce.EntireRow.Copy Worksheets("Database Duplicati").Cells(j, 1)
                End If
            End If
        Next
    
    
    End With
End Sub

 

[FROST220684Partecipante FROST220684]

vecchio frac ha scritto:

Sul file che hai inviato ho provato questo codice e sembra funzionare

funziona perfettamente!!!

guardandolo però mi sono sorti alcune problematiche:

1. è possibile raggruppare i duplicati? nel senso in questo modo lui li trova e li aggiunge in modo sparso mi sarebbe utile che i duplicati stiano vicino per una questione di visualizzazione. se no devo utilizzare i trova ogni volta.

2. Oltre questa macro me ne servirebbe un'altra che elimini i duplicati e mi dia un database pulito, es.:

- se trova un duplicato mi copia una sola riga nel database pulito facendo attenzione al fatto che il duplicato si possa trovare anche in una sola colonna (per farti un esempio alcuni clienti chiamano dallo stesso numero ma utilizzano 2 email diverse e viceversa 2 numeri diversi ma stessa email ed a me interessa avere cmq una sola riga ed una sola email).

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

FROST220684 ha scritto:

guardandolo però mi sono sorti alcune problematiche:

C'è un bel po' di lavoro da fare. Non sono certo di poterti garantire assistenza completa nell'immediato. Se vuoi contattami in privato qui: vecchio_frac[at]hotmail.it e vediamo cosa possiamo fare (anche per non intasare una discussione ormai risolta).

[FROST220684Partecipante FROST220684]

dietro front mi sono confrontato con il capo e mi ha detto che possiamo farne a meno quindi meglio cosi si hai ragione se posso disturbarti mi servirebbe solo un altro paio di consigli chiudo la discussione e grazie

[Autore]

Articoli