Como modificar la función del siguiente código
Tengo el siguiente código, lo que hace es tomar un notepad seleccionado 152152456789-A
Identificar la ultima letra y de acuerdo a esa letra acomodarmelo en diferentes celdas de un formato, el código es el siguiente :
letra = Mid(. SelectedItems. Item(1), Len(. SelectedItems.Item(1)) - 4, 1)
If letra = "E" Then
col = Columns("C").Column
ElseIf letra = "D" Then
col = Columns("F").Column
Else
MsgBox "El archivo no tiene la nomenclatura", vbCritical, "ERROR DE ARCHIVO"
Exit Sub
End If
Como puedo hacer que cambie y me identifique códigos con 152152456789-A-B, como hago que me tome más caracteres del código de nombre del notepad, en lugar de detectar solo "A" ahora detecte "A-B"
1 respuesta
Te dejo un ejemplo de cómo extraer una cadena a partir de cierto caracter, en este caso el primer guión.
Sub extraeLetras() 'x Elsamatilde dato = "152152456789-A-B" 'busca el guión ubica = InStr(1, dato, "-") 'si lo encuentra extrae la cadena que sigue If ubica > 0 Then letras = Mid(dato, ubica + 1, Len(dato) - ubica) Else letras = "" End If MsgBox letras End Sub
Por supuesto que en lugar de la variable 'dato' debe ir tu item seleccionado.
Te anexo el siguiente código lo que hace es que me permite seleccionar un notepad con nombre 145852987753-A o 145852987753-B, debido a que es para reportes la serie va a cambiar lo único que permanece constante es la letra del final independientemente de los números que contenta, pero en lugar de reconocerme solo la A, ahora quiero que funcione con códigos 145852987753-A-A y 145852987753-A-B, anexo el código.
Sub LeerNotePad()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.ActiveSheet
ruta = l1.Path & "\"
ChDir ruta
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione archivo NotePad"
.Filters.Clear
.Filters.Add "All Files", "*.*"
.Filters.Add "Archivos Txt", "*.txt*"
.FilterIndex = 2
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show Then
letra = Mid(.SelectedItems.Item(1), Len(.SelectedItems.Item(1)) - 4, 1)
If letra = "A" Then
col = Columns("C").Column
ElseIf letra = "B" Then
col = Columns("H").Column
Else
MsgBox "El archivo no tiene la nomenclatura", vbCritical, "ERROR DE ARCHIVO"
Exit Sub
End If
'
num = 9
Set l2 = Workbooks.Open(.SelectedItems.Item(1))
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(num, col + 1) = dato1(1)
h1.Cells(num, col + 2) = dato1(3)
h1.Cells(num, col + 3) = dato2(1)
h1.Cells(num, col + 4) = dato2(3)
num = num + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
l2.Close
End If
End With
MsgBox "Proceso terminado", vbInformation, "LEER ARCHIVOS"
End Sub
El código que te dejé de ejemplo busca el guión y a partir de allí la cadena, no importando si es de 1, 2, o la cantidad de letras que tengas.
Lo que no queda claro es si se realizará una acción diferente si encuentra A, B, A-A, A-B, etc. Eso lo establecés en cada IF... ElseIF.
Si no encuentra el guión significa que no hay letras y cancela como ya lo tenías.
Sub LeerNotePad()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.ActiveSheet
ruta = l1.Path & "\"
ChDir ruta
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione archivo NotePad"
.Filters.Clear
.Filters.Add "All Files", "*.*"
.Filters.Add "Archivos Txt", "*.txt*"
.FilterIndex = 2
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show Then
'--------ajustada x Elsamatilde
dato = .SelectedItems.Item(1)
'busca el guión
ubica = InStr(1, dato, "-")
'si lo encuentra extrae la cadena que sigue
If ubica > 0 Then
letras = Mid(dato, ubica + 1, Len(dato) - ubica)
If letras = "A" Then
col = Columns("C").Column
ElseIf letras = "B" Then
col = Columns("H").Column
ElseIf letras = "A-B" Then
'para cuando encuentre A-B
Else
'para cualquier otro caso distinto
End If
Else
'no encontró letras
MsgBox "El archivo no tiene la nomenclatura", vbCritical, "ERROR DE ARCHIVO"
Exit Sub
End If
'----------------
num = 9
Set l2 = Workbooks.Open(.SelectedItems.Item(1))
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(num, col + 1) = dato1(1)
h1.Cells(num, col + 2) = dato1(3)
h1.Cells(num, col + 3) = dato2(1)
h1.Cells(num, col + 4) = dato2(3)
num = num + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
l2.Close
End If
End With
MsgBox "Proceso terminado", vbInformation, "LEER ARCHIVOS"
End SubSdos!
Tal cual esta no me funciona :(, los valores ya no caen donde deberían, aquí anexo mi excel base más dos notepad, busco que pueda reconocerme notepad 123456789123-A-A mediante la terminación A-A lo mande a las celdas correspondientes, actualmente lo hace con A y B ahora necesito que sea con A-A Y N-A
Hasta ahora tenías que si es A vaya a col C y si es B vaya a col H.
Que tal entonces si me aclaras dónde debe ir A-A, A-B etc que dejé indicado para que completes en estas líneas:
ElseIf letras = "A-B" Then 'para cuando encuentre A-B Else 'para cualquier otro caso distinto End If
