Como extraer notepads a excel, por medio de una serie
Tengo el siguiente código que extrae los notepads, de la carpeta donde esta ubicado el excel con terminación A, B, C, DE, E, F, G, H, Y los extrae a dichas celdas del formato, las series de los notepads son 123456789123-A de 12 dígitos y una letra, ahora busco que se tome el valor de la celda DEF5 donde se encontraran los 12 dígitos, busque los notepads con esa serie que vendrán de la siguiente forma 123456789123-A, cambiando la letra hasta la H, y los acomode de acuerdo a las celdas asignadas para cada letra.
1 Respuesta
H o l a:
Te anexo la macro, le agregué el código para que te aparezca el navegador de carpetas, selecciona la carpeta y presiona Acepta, la macro leerá únicamente los archivos que contenga el número de serie de la celda D5
Sub LeerNotePad2()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.ActiveSheet
'
ruta = l1.Path & "\"
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona una carpeta"
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show <> -1 Then Exit Sub
cp = .SelectedItems(1)
End With
'
serie = h1.[D5]
If serie = "" Then
MsgBox "Falta el número de serie", vbCritical, "ERROR"
Exit Sub
End If
'
lets = Array("A", "B", "C", "D", "E", "F", "G", "H")
cols = Array("C", "H", "C", "H", "C", "H", "C", "H")
fils = Array(9, 9, 24, 24, 39, 39, 54, 54)
'
arch = Dir(cp & "\" & serie & "*.txt")
Do While arch <> ""
letra = Mid(arch, Len(arch) - 4, 1)
arr = ""
For i = LBound(lets) To UBound(lets)
If letra = lets(i) Then
arr = i
Exit For
End If
Next
If arr <> "" Then
col = Columns(cols(arr)).Column
fil = fils(arr)
Set l2 = Workbooks.Open(ruta & arch)
Set h2 = l2.Sheets(1)
Set r = h2.Columns("A")
Set b = r.Find("Ch.", lookat:=xlPart)
If Not b Is Nothing Then
ncell = b.Address
Do
dato1 = Split(h2.Cells(b.Row + 1, "A"), ",")
dato2 = Split(h2.Cells(b.Row + 2, "A"), ",")
h1.Cells(fil, col + 1) = dato1(1)
h1.Cells(fil, col + 2) = dato1(3)
h1.Cells(fil, col + 3) = dato2(1)
h1.Cells(fil, col + 4) = dato2(3)
fil = fil + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
l2.Close
End If
arch = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Proceso terminado", vbInformation, "LEER ARCHIVOS"
End Sub‘
S a l u d o s . D a n t e A m o r. Recuerda valorar la respuesta. G r a c i a s
