VBA - Trasferire un range di dati da multipli workbooks ad un master file mantenendo la formattazione

Question

Ciao a tutti,

io ho 51 file excel in una cartella. Ogni file excel contiene un range di valori numerici J4:R4 (foglio 1) che voglio trasferire nel mio master file matenendo il formato. Il file finale quindi avrà 51 righe contenenti celle con valore numerico che vanno da A1 ad I1, con lo stesso formato dei file originali da cui sono stati trasferiti. Questo è il codice che uso:

Sub LoopThroughDirectory() 
Dim MyFile As String
Dim pp As Workbook
Dim row As Integer
row = 1

MyFile = Dir("C:\Users\Aaa\Desktop\Analysed Data\*.xls*")

Do While MyFile <> ""
Workbook.Open ("C:\Users\Aaa\Desktop\Analysed Data\")
Worksheets("sheet1").Select
Range("J4:R4").Select
Selection.Copy
ActiveWindow.Close

Set pp = Workbook
Windows("pp.xlsx").Activate
Worksheets("sheet1").Cells(row, 1) = MyFile
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False

row = row + 1 
Loop

End Sub

Ho cambiato talmente tanti codici che non so più cosa fare.

Grazie a chiunque risponderà.

Silvia

Answer 1

Ciao Silvia,

Benvenuta nella Community!

VBA - Trasferire un range di dati da multipli workbooks ad un master file mantenendo la formattazione 

Ciao a tutti,

io ho 51 file excel in una cartella. Ogni file excel contiene un range di valori numerici J4:R4 (foglio 1) che voglio trasferire nel mio master file matenendo il formato. Il file finale quindi avrà 51 righe contenenti celle con valore numerico che vanno da A1 ad I1, con lo stesso formato dei file originali da cui sono stati trasferiti. Questo è il codice che uso:

Sub LoopThroughDirectory() 

Dim MyFile As String

Dim pp As Workbook

Dim row As Integer

row = 1

MyFile = Dir("C:\Users\Aaa\Desktop\Analysed Data\*.xls*")

Do While MyFile <> ""

Workbook.Open ("C:\Users\Aaa\Desktop\Analysed Data")

Worksheets("sheet1").Select

Range("J4:R4").Select

Selection.Copy

ActiveWindow.Close

Set pp = Workbook

Windows("pp.xlsx").Activate

Worksheets("sheet1").Cells(row, 1) = MyFile

Range("A1").Select

Selection.PasteSpecial Paste:=xlPasteValues, Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _

    :=False, Transpose:=False

Application.CutCopyMode = False

row = row + 1 

Loop

End Sub

Ho cambiato talmente tanti codici che non so più cosa fare.

In un modulo di codice standard, incolla il seguente codice:

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

Option Explicit

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

Public Sub Tester()

    Dim FSO As Object

    Dim oFile As Object

    Dim oFiles As Object

    Dim oFolder As Object

    Dim srcWb As Workbook, destWB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim iCtr As Long

    Dim CalcMode As Long

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

    Const sPercorso As String = _

          "**C:\Users\Aaa\Desktop\Analysed Data**"      '<<=== Modifica

    Const sFileType As String = "*.xls?"                      '<<=== Modifica

    Const sIntervallo As String = "J4:R4"                   '<<=== Modifica

    On Error GoTo XIT

    Set destWB = ThisWorkbook

    With destWB

        On Error Resume Next

        With Application

            .EnableEvents = False

            .ScreenUpdating = False

            CalcMode = .Calculation

            .Calculation = xlCalculationManual

        End With

        If Not SheetExists(sSummary) Then

            Set destSH = destWB.Sheets.Add(After:=.Sheets(.Sheets.Count))

            destSH.Name = sSummary

        Else

            Set destSH = .Sheets(sSummary)

            destSH.UsedRange.Clear

        End If

    End With

    Set FSO = CreateObject("Scripting.FileSystemObject")

    Set oFolder = FSO.GetFolder(sPercorso)

    Set oFiles = oFolder.Files

    For Each oFile In oFiles

        With oFile

            If .Name Like sFileType Then

                iCtr = iCtr + 1

                Set srcWb = Workbooks.Open(oFile)

                Set srcSH = srcWb.Sheets(1)

                Set srcRng = srcSH.Range(sIntervallo)

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

                srcRng.Copy Destination:=destRng

                srcWb.Close savechanges:=False

            End If

        End With

    Next oFile

XIT:

    With Application

        .ScreenUpdating = True

        .Calculation = CalcMode

        .EnableEvents = True

    End With

End Sub

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

Public Function SheetExists(sSheetName As String, _

                            Optional ByVal WB As Workbook) As Boolean

    On Error Resume Next

    If WB Is Nothing Then

        Set WB = ThisWorkbook

    End If

    SheetExists = CBool(Len(WB.Sheets(sSheetName).Name))

End Function

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

===

Regards,

Norman