Excel macro per copiare dati da colonne di file a colonne di un altro file archivio

Question

Excel macro per copiare dati da colonne di file a colonne di un altro file archivio

Anonimo

Ciao,

ho ricevuto il seguente codice vb in risposta ad un altro post. Serve per trasferire i dati da un foglio ad un altro.

Option Explicit

Dim oFSO As Object

'--------->>

Public Sub Tester()

Dim oFolder As Object

Dim oFiles As Object

Dim oFile As Object

Dim srcWB As Workbook, destWB As Workbook

Dim srcSH As Worksheet, destSH As Worksheet

Dim srcRng As Range, destRng As Range

Dim sPercorso As String

Dim iCtr As Long

Dim sMsg As String, sTitle As String, iButtons As Long

Dim iRow As Long, jRow As Long

Dim CalcMode As Long

Const sNomeFoglioSorgente As String = _

"Foglio1" '<<=== Modifica

Const sNomeFoglioDestinazione As String = _

"Riepilogo" '<<=== Modifica

Const sColonneDaCopiare As String = _

"A:B,K:K,O:O,Q:Q,U:U" '<<=== Modifica

Const iRigaIntestazioneDestinazione As Long = 12 '<<=== Modifica

Const iPrimaRigaSorgente As Long = 8 '<<=== Modifica

sPercorso = GetDirectory

If sPercorso = vbNullString Then

sMsg = "Non hai scelto una directory ! "

sTitle = "CODICE TERMINATO !"

iButtons = vbCritical

GoTo XIT

End If

Set oFolder = oFSO.GetFolder(sPercorso)

Set oFiles = oFolder.Files

Set destWB = ThisWorkbook

Set destSH = destWB.Sheets(sNomeFoglioDestinazione)

With destSH

iRow = LastRow(destSH, .Columns("A:A"), iRigaIntestazioneDestinazione)

Set destRng = .Range("A" & iRow + 1)

End With

On Error GoTo ErrHandler

With Application

CalcMode = .Calculation

.Calculation = xlCalculationManual

.ScreenUpdating = False

End With

For Each oFile In oFiles

Set srcWB = Workbooks.Open(oFile.Path)

iCtr = iCtr + 1

With srcWB

Set srcSH = srcWB.Sheets(sNomeFoglioSorgente)

With srcSH

jRow = LastRow(srcSH, .Range(sColonneDaCopiare))

Set srcRng = Intersect(srcSH.Range(sColonneDaCopiare), _

.Rows(iPrimaRigaSorgente & ":" & jRow))

End With

srcRng.Copy Destination:=destRng

Set destRng = destRng.Offset(srcRng.Rows.Count)

srcWB.Close SaveChanges:=False

End With

Next oFile

If CBool(iCtr) Then

sMsg = "Dati da " & iCtr _

& " file trovati nella directory " _

& vbNewLine _

& sPercorso _

& vbNewLine _

& " sono stato copiati nel foglio "

sTitle = "REPORT"

iButtons = vbInformation

Else

sMsg = "Nessun file è stato trovato nella directory " & sPercorso & " !"

sTitle = "FILE NON TROVATI !"

iButtons = vbCritical

End If

XIT:

Call MsgBox( _

Prompt:=sMsg, _

Buttons:=iButtons, _

Title:=sTitle)

With Application

.Calculation = CalcMode

.ScreenUpdating = True

End With

Set oFile = Nothing

Set oFiles = Nothing

Set oFolder = Nothing

Set oFSO = Nothing

On Error GoTo 0

Exit Sub

ErrHandler:

sMsg = "Errore " & Err.Number _

& " (" & Err.Description & ") nella routine Worksheet_Activate"

iButtons = vbCritical

sTitle = "ERRORE"

Resume XIT

End Sub

'--------->>

Public Function GetDirectory() As String

Dim oShellApp As Object

Dim sPercorso As String

Dim bProblem As Boolean

Set oFSO = CreateObject("Scripting.FileSystemObject")

Do

bProblem = False

Set oShellApp = CreateObject("Shell.Application"). _

Browseforfolder(0, "SELEZIONA UNA FOLDER", 0, "c:\")

On Error Resume Next

sPercorso = oShellApp.self.Path

If Err.Number <> 0 Then

If MsgBox(Prompt:="Non hai scelto una cartella valida!" _

& vbNewLine & vbNewLine & _

"Vuoi riprovare?", _

Buttons:=vbYesNoCancel, _

Title:="CARTELLA NECESSARIA !") <> vbYes Then

Exit Function

End If

bProblem = True

End If

On Error GoTo 0

Loop Until bProblem = False

GetDirectory = sPercorso

End Function

'--------->>

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range, _

Optional minRow As Long = 1)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastRow = Rng.Find(What:="*", _

after:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

If LastRow < minRow Then

LastRow = minRow

End If

End Function

La macro funziona molto bene solo che copia le colonne del foglio sorgente non nell'ordine che vorrei. Mi spiego: questa macro

Copia la colonna A nel file sorgente in A nel file di riepilogo

Copia la colonna B nel file sorgente in B nel file di riepilogo

Copia la colonna K nel file sorgente in C nel file di riepilogo

Copia la colonna O nel file sorgente in D nel file di ripilogo

Copia la colonna Q nel file sorgente in E nel file di ripilogo

Copia la colonna U nel file sorgente in F nel file di ripilogo

Quello che vorrei invece sarebbe:

colonna A del file sorgente in colonna A del file di riepilogo

colonna B del file sorgente in colonna C del file di riepilogo

colonna K del file sorgente in colonna D del file di riepilogo

colonna O del file sorgente in colonna G del file di riepilogo

colonna Q del file sorgente in colonna H del file di riepilogo

colonna U del file sorgente in colonna U del file di riepilogo

Come dovrei modificarla

Grazie mille

Luca

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

Answer 1

Ciao Luca,

ho ricevuto il seguente codice vb in risposta ad un altro post. Serve per trasferire i dati da un foglio ad un altro.

Option Explicit

Dim oFSO As Object

'--------->>

Public Sub Tester()

Dim oFolder As Object

Dim oFiles As Object

Dim oFile As Object

Dim srcWB As Workbook, destWB As Workbook

Dim srcSH As Worksheet, destSH As Worksheet

Dim srcRng As Range, destRng As Range

Dim sPercorso As String

Dim iCtr As Long

Dim sMsg As String, sTitle As String, iButtons As Long

Dim iRow As Long, jRow As Long

Dim CalcMode As Long

Const sNomeFoglioSorgente As String = _

"Foglio1" '<<=== Modifica

Const sNomeFoglioDestinazione As String = _

"Riepilogo"   '<<=== Modifica

Const sColonneDaCopiare As String = _

"A:B,K:K,O:O,Q:Q,U:U"   '<<=== Modifica

Const iRigaIntestazioneDestinazione As Long = 12 '<<=== Modifica

Const iPrimaRigaSorgente As Long = 8 '<<=== Modifica

sPercorso = GetDirectory

If sPercorso = vbNullString Then

sMsg = "Non hai scelto una directory ! "

sTitle = "CODICE TERMINATO !"

iButtons = vbCritical

GoTo XIT

End If

Set oFolder = oFSO.GetFolder(sPercorso)

Set oFiles = oFolder.Files

Set destWB = ThisWorkbook

Set destSH = destWB.Sheets(sNomeFoglioDestinazione)

With destSH

iRow = LastRow(destSH, .Columns("A:A"), iRigaIntestazioneDestinazione)

Set destRng = .Range("A" & iRow + 1)

End With

On Error GoTo ErrHandler

With Application

CalcMode = .Calculation

.Calculation = xlCalculationManual

.ScreenUpdating = False

End With

For Each oFile In oFiles

Set srcWB = Workbooks.Open(oFile.Path)

iCtr = iCtr + 1

With srcWB

Set srcSH = srcWB.Sheets(sNomeFoglioSorgente)

With srcSH

jRow = LastRow(srcSH, .Range(sColonneDaCopiare))

Set srcRng = Intersect(srcSH.Range(sColonneDaCopiare), _

.Rows(iPrimaRigaSorgente & ":" & jRow))

End With

srcRng.Copy Destination:=destRng

Set destRng = destRng.Offset(srcRng.Rows.Count)

srcWB.Close SaveChanges:=False

End With

Next oFile

If CBool(iCtr) Then

sMsg = "Dati da " & iCtr _

& " file trovati nella directory " _

& vbNewLine _

& sPercorso _

& vbNewLine _

& " sono stato copiati nel foglio "

sTitle = "REPORT"

iButtons = vbInformation

Else

sMsg = "Nessun file è stato trovato nella directory " & sPercorso & " !"

sTitle = "FILE NON TROVATI !"

iButtons = vbCritical

End If

XIT:

Call MsgBox( _

Prompt:=sMsg, _

Buttons:=iButtons, _

Title:=sTitle)

With Application

.Calculation = CalcMode

.ScreenUpdating = True

End With

Set oFile = Nothing

Set oFiles = Nothing

Set oFolder = Nothing

Set oFSO = Nothing

On Error GoTo 0

Exit Sub

ErrHandler:

sMsg = "Errore " & Err.Number _

& " (" & Err.Description & ") nella routine Worksheet_Activate"

iButtons = vbCritical

sTitle = "ERRORE"

Resume XIT

End Sub

'--------->>

Public Function GetDirectory() As String

Dim oShellApp As Object

Dim sPercorso As String

Dim bProblem As Boolean

Set oFSO = CreateObject("Scripting.FileSystemObject")

Do

bProblem = False

Set oShellApp = CreateObject("Shell.Application"). _

Browseforfolder(0, "SELEZIONA UNA FOLDER", 0, "c:\")

On Error Resume Next

sPercorso = oShellApp.self.Path

If Err.Number <> 0 Then

If MsgBox(Prompt:="Non hai scelto una cartella valida!" _

& vbNewLine & vbNewLine & _

"Vuoi riprovare?", _

Buttons:=vbYesNoCancel, _

Title:="CARTELLA NECESSARIA !") <> vbYes Then

Exit Function

End If

bProblem = True

End If

On Error GoTo 0

Loop Until bProblem = False

GetDirectory = sPercorso

End Function

'--------->>

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range, _

Optional minRow As Long = 1)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastRow = Rng.Find(What:="*", _

after:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

If LastRow < minRow Then

LastRow = minRow

End If

End Function

La macro funziona molto bene solo che copia  le colonne del foglio sorgente non nell'ordine che vorrei. Mi spiego: questa macro

Copia la colonna A nel file sorgente in A nel file di riepilogo

Copia la colonna B nel file sorgente in B nel file di riepilogo

Copia la colonna K nel file sorgente in C nel file di riepilogo

Copia la colonna O nel file sorgente in D nel file di ripilogo

Copia la colonna Q nel file sorgente in E nel file di ripilogo

Copia la colonna U nel file sorgente in F nel file di ripilogo

Quello che vorrei invece sarebbe:

colonna A del file sorgente in colonna A del file di riepilogo

colonna B del file sorgente in colonna C del file di riepilogo

colonna K del file sorgente in colonna D del file di riepilogo

colonna O del file sorgente in colonna G del file di riepilogo

colonna Q del file sorgente in colonna H del file di riepilogo

colonna U del file sorgente in colonna U del file di riepilogo

Come dovrei modificarla

Prova qualcosa del genere:

'=========>>

Option Explicit

Dim oFSO As Object

'--------->>

Public Sub Tester()

Dim oFolder As Object

Dim oFiles As Object

Dim oFile As Object

Dim srcWB As Workbook, destWB As Workbook

Dim srcSH As Worksheet, destSH As Worksheet

Dim srcRng As Range, destRng As Range

Dim arrSorgente As Variant, arrDestinazione As Variant

Dim sPercorso As String

Dim i As Long, iCtr As Long, jCtr As Long

Dim sMsg As String, sTitle As String, iButtons As Long

Dim iRow As Long, jRow As Long

Dim CalcMode As Long

Const sNomeFoglioSorgente As String = "Foglio1" '<<=== Modifica

Const sNomeFoglioDestinazione As String = "Riepilogo" '<<=== Modifica

Const sColonneSorgente As String = "A,B,K,O,Q,U" '<<=== Modifica

Const sColonneDestinazione As String = "A,C,D,G,H,E" '<<=== Modifica

Const iRigaIntestazioneDestinazione As Long = 12 '<<=== Modifica

Const iPrimaRigaSorgente As Long = 8 '<<=== Modifica

sPercorso = GetDirectory

If sPercorso = vbNullString Then

sMsg = "Non hai scelto una directory ! "

sTitle = "CODICE TERMINATO !"

iButtons = vbCritical

GoTo XIT

End If

Set oFolder = oFSO.GetFolder(sPercorso)

Set oFiles = oFolder.Files

Set destWB = ThisWorkbook

Set destSH = destWB.Sheets(sNomeFoglioDestinazione)

With destSH

iRow = LastRow(destSH, .Columns("A:A"), _

iRigaIntestazioneDestinazione) + 1

Set destRng = .Range("A" & iRow)

End With

arrSorgente = Split(sColonneSorgente, ",")

arrDestinazione = Split(sColonneDestinazione, ",")

On Error GoTo ErrHandler

With Application

CalcMode = .Calculation

.Calculation = xlCalculationManual

.ScreenUpdating = False

End With

For Each oFile In oFiles

Set srcWB = Workbooks.Open(oFile.Path)

iCtr = iCtr + 1

With srcWB

Set srcSH = srcWB.Sheets(sNomeFoglioSorgente)

With srcSH

jRow = LastRow(srcSH, .Range("A:A"), 8)

For i = 0 To UBound(arrSorgente)

Set srcRng = srcSH.Range(arrSorgente(i) _

& iPrimaRigaSorgente + 1). _

Resize(jRow - iPrimaRigaSorgente)

Set destRng = destSH.Range(arrDestinazione(i) _

& iRow)

srcRng.Copy Destination:=destRng

Next i

End With

iRow = iRow + jRow - iPrimaRigaSorgente

srcWB.Close SaveChanges:=False

End With

Next oFile

If CBool(iCtr) Then

sMsg = "Dati da " & iCtr _

& " file trovati nella directory " _

& vbNewLine _

& sPercorso _

& vbNewLine _

& " sono stato copiati nel foglio "

sTitle = "REPORT"

iButtons = vbInformation

Else

sMsg = "Nessun file è stato trovato nella directory " _

& sPercorso & " !"

sTitle = "FILE NON TROVATI !"

iButtons = vbCritical

End If

XIT:

Call MsgBox( _

Prompt:=sMsg, _

Buttons:=iButtons, _

Title:=sTitle)

With Application

.Calculation = CalcMode

.ScreenUpdating = True

End With

Set oFile = Nothing

Set oFiles = Nothing

Set oFolder = Nothing

Set oFSO = Nothing

On Error GoTo 0

Exit Sub

ErrHandler:

sMsg = "Errore " & Err.Number _

& " (" & Err.Description & ") nella routine Worksheet_Activate"

iButtons = vbCritical

sTitle = "ERRORE"

Resume XIT

End Sub

'--------->>

Public Function GetDirectory() As String

Dim oShellApp As Object

Dim sPercorso As String

Dim bProblem As Boolean

Set oFSO = CreateObject("Scripting.FileSystemObject")

Do

bProblem = False

Set oShellApp = CreateObject("Shell.Application"). _

Browseforfolder(0, "SELEZIONA UNA FOLDER", 0, "c:\")

On Error Resume Next

sPercorso = oShellApp.self.Path

If Err.Number <> 0 Then

If MsgBox(Prompt:="Non hai scelto una cartella valida!" _

& vbNewLine & vbNewLine & _

"Vuoi riprovare?", _

Buttons:=vbYesNoCancel, _

Title:="CARTELLA NECESSARIA !") <> vbYes Then

Exit Function

End If

bProblem = True

End If

On Error GoTo 0

Loop Until bProblem = False

GetDirectory = sPercorso

End Function

'--------->>

Public Function LastRow(SH As Worksheet, _

Optional Rng As Range, _

Optional minRow As Long = 1)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastRow = Rng.Find(What:="*", _

after:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

If LastRow < minRow Then

LastRow = minRow

End If

End Function

'<<=========

===

Regards,

Norman

Answer 2

Ciao Luca,

Ti ringrazio problema risolto utile come sempre!

Prego!

A scopo informativo, esiste il modo per abbinare alla macro un tasto che ti permetta di fare l'operazione senza dovere ricorrere aad ALT+F( ed esegui macro?

Certo! Vedi:

Assegnare una macro a una maschera o un pulsante di controllo

===

Regards,

Norman

Answer 3

Anonimo

Ti ringrazio problema risolto utile come sempre!

A scopo informativo, esiste il modo per abbinare alla macro un tasto che ti permetta di fare l'operazione senza dovere ricorrere aad ALT+F( ed esegui macro?

Grazie

Luca

0 commenti