come da titolo devo riuscire a copiare alcuni dati all'interno di file excel, questi dati sono presenti sempre nella cella B7
e poi dalla cella A14 B14, A15 B15 fino a quando non incontro una cella vuota.
I dati importati devono essere messi tutti sulla stessa riga per ogni singolo file elaborato.
Io ignorante in materia ho copiato spudoratamente questa macro cercando di adattarla al mio caso, ma non riesco a selezionare le celle in questione e copiarle in riga.
- Codice: Seleziona tutto
Option Explicit
Public MioFile As String, MioPercorso As String, Wb1 As String, Wb2 As String, UR As Integer
Sub Leggi_File()
Dim I As Integer
I = 0
Application.ScreenUpdating = False
Foglio1.Select
[A1] = "cod_im"
[B1] = "A"
[C1] = "B"
[D1] = "C"
[E1] = "D"
[F1] = "E"
[G1] = "F"
MioPercorso = "C:\Users\administrator\Desktop\gina_elena\" ' << -------------- QUI devi inserire il tuo percorso
MioFile = Dir(MioPercorso & "*.xls") ' << -------------- Il file che esegue questa macro non deve stare nella stessa cartella dove ci sono i files da importare
Do While MioFile <> ""
I = I + 1
Copia_Dati
MioFile = Dir()
Loop
Columns("A:A").ColumnWidth = 5
Columns("B:B").ColumnWidth = 4
Columns("C:C").ColumnWidth = 45
Columns("D:D").ColumnWidth = 40
Columns("E:E").ColumnWidth = 40
Columns("F:F").ColumnWidth = 40
Columns("G:G").ColumnWidth = 40
Columns("C:G").Select
With Selection
.VerticalAlignment = xlTop
.WrapText = True
End With
[A1].Select
Application.ScreenUpdating = True
Dim Cell
For Each Cell In ActiveSheet.UsedRange
Cell.Value = Replace(Cell.Value, Chr(10), " ")
Next Cell
MsgBox "Sono stati COPIATI i dati di '" & I & "' file" & Chr(10) & Chr(10) & _
"presenti nel percorso: '" & MioPercorso & "'"
End Sub
Sub Copia_Dati()
Dim Matr1(1 To 7) As Integer
Wb1 = ActiveWorkbook.Name
Workbooks.Open Filename:=MioPercorso & MioFile
Wb2 = ActiveWorkbook.Name
UR = Range("A" & Rows.Count).End(xlUp).Row
Range("A2", Cells(UR, 7)).Copy
Windows(Wb1).Activate
Sheets("Foglio1").Select
UR = Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & UR).Select
Selection.PasteSpecial Paste:=xlPasteValues
Windows(Wb2).Activate
Application.DisplayAlerts = False
ActiveWindow.Close
Application.DisplayAlerts = True
Windows(Wb1).Activate
With Selection
.VerticalAlignment = xlTop
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Grazie anticipatamente per l'aiuto