Excel - Copiar dos celdas de miles de ficheros

 
Vista:

Copiar dos celdas de miles de ficheros

Publicado por Pablo (42 intervenciones) el 25/02/2017 12:17:13
Tengo un problema atragantado.

Tengo alrededor de cinco mil archivos Excel que contienen albaranes en un directorio, y necesito copiar dos celdas (siempre las mismas) de esos archivos para hacer una tabla con ellas.

Los archivos Excel tienen un nombre diferente cada uno, aunque su contenido es el mismo. Contienen una plantilla con un albarán con la misma estructura. Las celdas que pretendo copiar son las mismas en cada archivo.

¿Cómo puedo hacer para leerlos todos?

Gracias de antemano.
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
sin imagen de perfil
Val: 112
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

Copiar dos celdas de miles de ficheros

Publicado por José Luis (46 intervenciones) el 25/02/2017 16:12:01
Hola,

Una vez encontré una macro que me permitía juntar varias hojas en una sola y la modifiqué para mis necesidades.

Tal vez esa te puede servir.

Básicamente abres el directorio, seleccionas todos los archivos y solo la celda que quieras las puedes pegar en una sola hoja.

Espero te pueda ayudar.


Saludos
José Luis
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de wordexperto.com
Val: 6.373
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

Copiar dos celdas de miles de ficheros

Publicado por wordexperto.com (2801 intervenciones) el 25/02/2017 16:57:39
Hola Pablo:
Esto parece un trabajo para tablas dinámicas, si tienes tus datos bien estructurados. Sube el archivo o un ejemplo, si necesitas ocultar datos confidenciales, y te podremos ayudar mejor.
https://wordexperto.com/blog/
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Andres Leonardo
Val: 3.136
Plata
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

Copiar dos celdas de miles de ficheros

Publicado por Andres Leonardo (1583 intervenciones) el 25/02/2017 19:09:52
En realidad es muy sencillo que quieres ... solo una pregunta

necesitas un buucle for each para el directorio asi buscas todos los documentos excel
y lo otro es es un copiar y pegar ....
Solo viene la pregunta la ruta existe hay sub directorios

cuales son las celdas .. sube unos 3 archivos ejemplo y con gusto te ayudare

**El concepto vale si son 3 5 50 500 5000 o lo qeu sea lo que va a cambiar es el tiempo de ejecucion ....

Saludos
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Copiar dos celdas de miles de ficheros

Publicado por JuanC (1237 intervenciones) el 26/02/2017 11:52:06
te dejo fragmentos de un código que hice para un trabajo particular
sólo te queda acomodarlo a tu problema...

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
Option Explicit
Option Private Module
Option Base 1
 
'//By JuanC - Feb. 2014
 
'//-- Procedimiento general -- //
'Seleccionar carpeta
'Ingresar nombre del archivo para Resumen
'Buscar recursivamente los libros dentro de la carpeta seleccionada
'Crear nuevo libro para Resumen
'Procesar cada libro encontrado (abre libro y copia las celdas específicas desde el libro al Resumen)
'Guardar Resumen
 
Public g_bCancel As Boolean
Public g_sFileName As String
 
Private m_wbk As Workbook
Private m_ws As Worksheet
Private m_vRng As Variant
Private m_vRng2 As Variant
Private m_fil As Long
Private m_Pivot As Range
 
Private Const cMAX = 10  '//Cantidad de celdas a extraer de cada planilla...
 
Private m_sRoot As String
 
'//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
Private Sub SeleccionarCarpeta()
m_sRoot = Browse("Seleccionar carpeta")
If m_sRoot <> "" Then
   m_sRoot = m_sRoot & "\"
End If
End Sub
 
Private Sub Crear_resumen()
Dim n&, lTotal&, dlg As Variant
 
If m_sRoot <> "" Then
 
   '//Diálogo para pedir nombre para guardar archivo de resumen...
   dlg = Application.GetSaveAsFilename("", FileFilter:="Libros de Excel(*.xlsx), *.xlsx", Title:="Guardar resumen como...")
   If dlg <> False Then
      g_sFileName = dlg
   Else
        g_bCancel = True
        Exit Sub
   End If
 
   g_bCancel = False
 
   DoEvents
   n = ScanFiles(m_sRoot, lTotal)
 
   MsgBox "Proceso finalizado!" & vbCrLf & "Se procesaron " & n & " de " & lTotal & " libros.", vbInformation, "Información"
 
   g_bCancel = True
Else
     MsgBox "Por favor seleccione una carpeta.", vbExclamation, "Atención"
End If
End Sub
 
'//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
 
Private Function ScanFiles(ByVal sRoot As String, ByRef n As Long) As Long
Dim sFolder$, sFileName$
Dim colDir As Collection, colFiles As Collection
Dim lCount&, i&, j&, lFilesCount&, tbl As Range
On Error Resume Next
 
'//Colecciones para carpetas y archivos...
Set colDir = New Collection
Set colFiles = New Collection
 
colDir.Add sRoot
lCount = 1
lFilesCount = 0
 
Do While lCount <= colDir.Count    '//Escaneo recursivo de directorios...
   sRoot = colDir(lCount)
   sFolder = Dir(sRoot, vbDirectory + vbNormal)
   Do While sFolder <> ""
      If sFolder <> "." And sFolder <> ".." Then
         If (GetAttr(sRoot & sFolder) And vbDirectory) = vbDirectory Then
            colDir.Add sRoot & sFolder & "\"
         Else
              sFileName = VBA.LCase(sRoot & sFolder)
              If VBA.Right(sFileName, 4) = ".xls" Or VBA.Right(sFileName, 5) = ".xlsm" Or VBA.Right(sFileName, 5) = ".xlsx" Then
                 colFiles.Add sFileName
              End If
         End If
      End If
      sFolder = Dir
   Loop
   lCount = lCount + 1
Loop
 
n = colFiles.Count '//Cantidad de archivos encontrados...
 
If n > 0 Then   '//Si encontró archivos crea un libro para resumen...
   Set m_wbk = Excel.Workbooks.Add
   Set m_ws = m_wbk.Sheets.Add
   Set m_Pivot = m_ws.Range("A1")
   m_ws.Name = "resumen"
   m_fil = 1                   '//Offset vertical para guardar datos en resumen...
 
   Application.DisplayAlerts = False
   For i = m_wbk.Sheets.Count To 1 Step -1  '//Elimina hojas innecesarias...
       If m_wbk.Sheets(i).Name <> "resumen" Then m_wbk.Sheets(i).Delete
   Next
   Application.DisplayAlerts = True
End If
 
              '//1         2       3        4        5        6        7        8       9         10
m_vRng = Array(("H11"), ("A14"), ("B14"), ("C14"), ("C16"), ("G16"), ("C24"), ("E25"), ("B28"), ("F28"))  '//Celdas que serán copiadas...
 
Application.ScreenUpdating = False
For i = 1 To colFiles.Count            '//Procesa todos los archivos encontrados...
    Call Process(colFiles.Item(i))
    lFilesCount = lFilesCount + 1
    If g_bCancel Then Exit For
    DoEvents
Next
 
If Not m_wbk Is Nothing Then  '//Guarda libro resumen...
   m_wbk.SaveAs Filename:=g_sFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
   m_wbk.Close
End If
 
fin:
 
Application.ScreenUpdating = True
ScanFiles = lFilesCount
End Function
 
Private Sub Process(ByVal sFileName As String)
Dim wbk As Workbook, ws1 As Worksheet, cell As Range
Dim i&
Dim vValues() As Variant
On Error Resume Next
Set wbk = Workbooks.Open(Filename:=sFileName)  '//Abre archivo a procesar...
 
Set ws1 = wbk.Sheets("Hoja1")    '//Hoja de planilla para extraer datos...
 
ReDim vValues(cMAX)
For i = 1 To cMAX
    Set cell = ws1.Range(m_vRng(i)).MergeArea.Cells(1, 1)   '//Carga datos de la plantilla...
    vValues(i) = VBA.Trim(cell.Value)
Next
 
m_Pivot.Offset(m_fil).Resize(, UBound(vValues)).Value = vValues      '//Copia datos en el resumen...
 
m_fil = m_fil + 1
 
wbk.Close SaveChanges:=False      '//Cierra archivo sin cambios...
Set wbk = Nothing
Set ws1 = Nothing
Set cell = Nothing
Erase vValues
End Sub
 
Private Function Browse(ByVal sTitle As String, Optional sPathIni As Variant) As String
Dim objShell As Object, objBrowse As Object, objFolder As Object
Browse = ""
On Error Resume Next
Set objShell = CreateObject("Shell.Application")
Set objBrowse = objShell.BrowseForFolder(0, sTitle, 0, 0) 'sPathIni)  17=Mipc 0=desktop
Set objFolder = objBrowse.Self
If Not objFolder Is Nothing Then
   Browse = objFolder.Path
End If
On Error GoTo 0
End Function
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar