Macro Rinomina File Txt Seguendo Dati Tabella

Anonimo
2017-03-02T11:56:02+00:00

Ciao a tutti,

avrei bisogno di un aiuto.

Ho una cartella con 15 file txt e il file Excel (nome Rinomina) con al suo interno  la Macro e le Tabelle di riferimento per il rinomina.

Vorrei rinominare nel seguente modo:

All'inizio di ogni file Excel c'e' un numero identificativo di 6 cifre.

La macro dovrebbe cercare il numeor di 6 cifre nella tabella (Colonna A e B) del file Excel (Foglio del File Rename, Codici)

e iniziare a rinominare il file con il valore corrispondente della tabella colonna B

REPORT NAME
RTV513 G1
SLS553 G2
POM531 G3
POM533 G4
ASN524 G5
ICT583 G6
ICT529 G7
INV184 G8
MRK532 G9
TRF511 G10
TRF514 G11

Poi dovrebbe controllare nella prima riga quello che c'e' Tra NomeAzienda Livee cercare la parola del paese nella seconda tabella del foglio codici Colonna D ed E il nome del paese e rinominarlo con il valore corrispondente da avere cosi alla fine quanto segue:

Bahrain 10
Italy 12
Uae 13

Esempio:

Prime 6 Cifre SLS553

Nome paese NomeAzienda Bahrain Live

nome finale txt dovrebbe essere G2 10

Se i file hanno le 6 cifre uguali li puo' rinominare come

G1A

G1B

G1C

Spero sia chiaro.

Ho caircato i file TXt e file Excel

https://1drv.ms/u/s!AufBGTjfOlupbdGYVyy74dP3FoE 

File 01.zip

Grazie

Lorenzo

Microsoft 365 e Office | Excel | Per la casa | Windows

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

3 risposte

Ordina per: Più utili
Più utili Più recente Meno recente
  1. Anonimo
    2017-03-05T11:16:53+00:00

    Alla fine ce l'ho fatta...ch fatica, anche perché conosco pochissimo il VB ma tra prog ad oggetti e formule Excel sono riuscito a raggiungere una soluz soddisfacente...

    certo penso non sia il massimo, ma fa il suo lavoro... certo se la potessi migliorare sarebbe piu' fico :)

    Sub Rename()

        Dim objFSO As Scripting.FileSystemObject

        Dim objFolder As Scripting.Folder

        Dim colFiles As Scripting.Files

        Dim objfile As Scripting.File

        Dim tsFile As Scripting.TextStream

        Dim strT As String

        Dim strT1 As String

        Set objFSO = CreateObject("Scripting.FileSystemObject")

        Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)

        Set colFiles = objFolder.Files

        For Each objfile In colFiles

        i = i + 1

            If objfile.Name Like "*.txt" Then

            Set tsFile = objfile.OpenAsTextStream(ForReading, TristateUseDefault)

    TryNextLine:

                If tsFile.AtEndOfStream Then GoTo NextFile

                strT = tsFile.ReadLine

                If InStr(1, LCase(strT), "NomeAzienda") > 0 And InStr(1, LCase(strT), "live") > 0 Then

                    tsFile.Close

                    'TextFile = objfile

                    'get the code name from the sting

                    strT1 = Trim(Left(strT, 10))

                    strT = Trim(Mid(strT, InStr(1, LCase(strT), "NomeAzienda") + 6, _

                    InStr(1, LCase(strT), "live") - InStr(1, LCase(strT), "NomeAzienda") - 6))

                    'lookup the new name from a table

                    strT1 = Application.VLookup(strT1, Worksheets("Codici").Range("A:B"), 2, False)

                    'lookup the new name from a table

                    strT = Application.VLookup(strT, Worksheets("Codici").Range("D:E"), 2, False)

                    'TextFile = FreeFile

                    'Open objfile For Input As TextFile

                    Name ThisWorkbook.Path & "" & objfile.Name As ThisWorkbook.Path & _

                    "" & (i - 1) & strT1 & strT & ".txt"

                Else

                    GoTo TryNextLine

                End If

            End If

    NextFile:

        Next

         'FileContent = Input(LOF(TextFile), TextFile)

        'Report Out Text File Contents

      MsgBox "Finito"

    End Sub

    La risposta è stata utile?

    0 commenti
  2. Anonimo
    2017-03-05T09:30:42+00:00

    ok ho modificato la macro e ho ottenuto la rinomina dei file come 101 102 103 e cosi via per quanti sono i file txt...

    ora devo fare si che davanti a questo 101 ci siano le prime 6 cifre trovate in testa la file txt...uhm not easy...

    Sub Rename()

        Dim objFSO As Scripting.FileSystemObject

        Dim objFolder As Scripting.Folder

        Dim colFiles As Scripting.Files

        Dim objfile As Scripting.File

        Dim tsFile As Scripting.TextStream

        Dim strT As String

        Set objFSO = CreateObject("Scripting.FileSystemObject")

        Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)

        Set colFiles = objFolder.Files

        For Each objfile In colFiles

        i = i + 1

            If objfile.Name Like "*.txt" Then

                Set tsFile = objfile.OpenAsTextStream(ForReading, TristateUseDefault)

    TryNextLine:

                If tsFile.AtEndOfStream Then GoTo NextFile

                strT = tsFile.ReadLine

                If InStr(1, LCase(strT), "NomeAzienda") > 0 And InStr(1, LCase(strT), "live") > 0 Then

                    tsFile.Close

                    'get the code name from the sting

                    strT = Trim(Mid(strT, InStr(1, LCase(strT), "NomeAzienda") + 6, _

                    InStr(1, LCase(strT), "live") - InStr(1, LCase(strT), "NomeAzienda") - 6))

                    'lookup the new name from a table

                    strT = Application.VLookup(strT, Worksheets("Codici").Range("D:E"), 2, False)

                    Name ThisWorkbook.Path & "" & objfile.Name As ThisWorkbook.Path & _

                    "" & strT & i & ".txt"

                Else

                    GoTo TryNextLine

                End If

            End If

    NextFile:

        Next

    End Sub

    La risposta è stata utile?

    0 commenti
  3. Anonimo
    2017-03-05T06:42:23+00:00

    Salve,

    io ho questa MAcro, pensate si possa modificare ed adattare a quanto mi occorre, perfavore?

    Grazie

    Sub Rename()

        Dim objFSO As Scripting.FileSystemObject

        Dim objFolder As Scripting.Folder

        Dim colFiles As Scripting.Files

        Dim objfile As Scripting.File

        Dim tsFile As Scripting.TextStream

        Dim strT As String

        Set objFSO = CreateObject("Scripting.FileSystemObject")

        Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)

        Set colFiles = objFolder.Files

        For Each objfile In colFiles

            If objfile.Name Like "*.txt" Then

                Set tsFile = objfile.OpenAsTextStream(ForReading, TristateUseDefault)

    TryNextLine:

                If tsFile.AtEndOfStream Then GoTo NextFile

                strT = tsFile.ReadLine

                If InStr(1, LCase(strT), "NomeAzienda") > 0 And InStr(1, LCase(strT), "live") > 0 Then

                    tsFile.Close

                    'get the code name from the sting

                    strT = Trim(Mid(strT, InStr(1, LCase(strT), "NomeAzienda") + 6, _

                    InStr(1, LCase(strT), "live") - InStr(1, LCase(strT), "NomeAzienda") - 6))

                    'lookup the new name from a table

                    strT = Application.VLookup(strT, Worksheets("Codici").Range("A:B"), 2, False)

                    Name ThisWorkbook.Path & "" & objfile.Name As ThisWorkbook.Path & _

                    "" & strT & ".txt"

                Else

                    GoTo TryNextLine

                End If

            End If

    NextFile:

        Next

    End Sub

    La risposta è stata utile?

    0 commenti