Autor
|
Tema: Buscar y reemplazar series en Word ( y otros VBA) (Leído 5,918 veces)
|
AmadeoIsaboya
Desconectado
Mensajes: 3
|
Hola, un saludo a todos de un recien llegado al foro. Quiero crear una rutina en word que me busque y reemplace series o listas predeterminadas. Me explico: Tengo muchos E-Book, y algunos son .pdf y necesito pasarlos a Word (el convertidor de Adobe no funciona muy bien, al menos en mi caso) por lo cual lo que hago es "copiar al portapapeles" y pegar en Word. Esto incluye los números de página, que al copiar me quedan como el resto del texto, incluidos entre el mismo. De manera que para que me quede un poco decente, tendría que empezar con el número 1 (pág 1) y reemplazarlo por un salto de línea, por un espacio, o por lo que sea recomendable en cada caso. Una vez encontrado el 1, ya no buscarlo más y pasar al 2, y así sucesivamente con todos los números de página que han quedado intercalados, recorriendo la "serie". A veces el programa encuentra una ocurrencia que no debe ser sustituida, por ejemplo el inicio del año 2009, por lo que quiero implementar la opción de "buscar siguiente 2" hasta encontrar el que me interesa. Otro caso es cuando un archivo ha quedado mal escaneado o convertido, a veces aparecen caracteres extraños tipo ascii. Si dispusiera de una lista de estos indeseados, podría pasársela como parámetro a la rutina de buscar y reemplazar, y en este caso sustituir todas las ocurrencias que aparezcan de cada elemento de esa lista, sin necesidad de pasarlos uno por uno al cuadro de diálogo. Y ya para rizar el rizo, entiendo que se podría hacer una lista de equivalencias, de forma que a un determinado carácter le corresponda su reemplazo. Supongo que a todo el mundo le ha pasado bajarse un texto y encontrar que letras acentuadas aparecen como '¥', '¤', '¢' cuando deberían ser á, ú, ó (es un ejemplo). Bueno, perdonad el "ladrillazo", pero es que me quería explicar bien. Si el tema ya ha salido y me quereis indicar la referencia, se agradecerá
|
|
|
En línea
|
|
|
|
ssccaann43 ©
Desconectado
Mensajes: 792
¬¬
|
Pues en ningún lado leí que estas haciendo un programa en VB y que tienes una duda de ¿?...
Creo que deberías meterte en las reglas del foro y leerlas.
Por otro lado, NO HACEMOS TAREAS. Ayudamos a corregir errores en codigos, aportamos ideas, te sacamos de dudas, pero NO HACEMOS TAREAS.
Salu2
|
|
|
En línea
|
- Miguel Núñez Todos tenemos derechos a ser estupidos, pero algunos abusan de ese privilegio... "I like ^TiFa^"
|
|
|
MCKSys Argentina
|
Si los pdf's estan en TXT plano, puedes leerlos y analizarlos usando VBA.
He hecho una macro en Excel que levanta PDF's. El tema es que varia mucho la programación dependiendo de la estructura que tenga el PDF...
Es muy parecido a leer TXT's en VB.
Saludos!
|
|
|
En línea
|
MCKSys Argentina "Si piensas que algo está bien sólo porque todo el mundo lo cree, no estás pensando."
|
|
|
AmadeoIsaboya
Desconectado
Mensajes: 3
|
Pues en ningún lado leí que estas haciendo un programa en VB y que tienes una duda de ¿?...
Creo que deberías meterte en las reglas del foro y leerlas.
Por otro lado, NO HACEMOS TAREAS. Ayudamos a corregir errores en codigos, aportamos ideas, te sacamos de dudas, pero NO HACEMOS TAREAS.
Salu2
Pues en ningún lado leí que estas haciendo un programa en VB y que tienes una duda de ¿?...
Creo que deberías meterte en las reglas del foro y leerlas.
Por otro lado, NO HACEMOS TAREAS. Ayudamos a corregir errores en codigos, aportamos ideas, te sacamos de dudas, pero NO HACEMOS TAREAS.
Salu2
1) He empezado diciendo que quiero hacer una rutina para WORD (supongo que con adaptaciones me servirá para EXCEL, ACCESS, etc.) que utilizan VBA, que yo sepa es VISUAL BASIC. 2) Cuando me he registrado he leído las reglas del foro y las he aceptado. He buscado si se había publicado algo parecido y YO no lo he encontrado. 3) Por otro lado, yo no he pedido a nadie que me haga ninguna TAREA, precisamente he pedido IDEAS para hacerlo yo, y he explicado un problema que a lo mejor se le ha planteado ya a mucha otra gente, tal vez alguno ya se ha buscado la vida como voy a hacer yo. O sea, no sé qué regla he incumplido, ya me la dirás tú si lo tienes por conveniente. De todas maneras, gracias por tu esplendida bienvenida a mi primer post en este foro.
|
|
|
En línea
|
|
|
|
MCKSys Argentina
|
Este es el código que hice (hace un tiempo ya) para "levantar" PDF's. Está diseñado para trabajar en Excel, pero cambiando un par de cosillas, anda en Word. Private Sub Command1_Click() Dim Pendientes As Worksheet Dim Linea As String Dim strAux As String Dim retMat() As String Dim streams() As String Dim IStreams As Long Dim capturando As Boolean Dim I As Long Dim J As Long Dim RowActual As Long Dim ColActual As Long Dim bAcu As Boolean Dim NombreCampo As String Dim cmdLine As String
Linea = "Está por importar datos de un PDF." + vbCrLf Linea = Linea + "Debe tener seleccionada la celda desde la cual se insertarán las nuevas celdas importadas." + vbCrLf Linea = Linea + "(La celda inical debe estar, preferentemente, al final de todas las anteriores)" + vbCrLf Linea = Linea + "¿ Ha seleccionado esta celda inicial ?" ret = MsgBox(Linea, vbQuestion + vbYesNo + vbDefaultButton1, "Atención") If ret <> vbYes Then Exit Sub
cmdLine = Application.GetOpenFileName("Archivos PDF (*.pdf),*.pdf", 1, "Abrir PDF", , False) If Dir(cmdLine) = "" Then Exit Sub
Set Pendientes = Worksheets("PENDIENTES2") 'Abre PDF para leer por lineas Open cmdLine For Input Access Read As #1 IStreams = 0 capturando = False Do While Not EOF(1) Line Input #1, Linea Linea = Trim(Linea) If Linea <> "" Then Select Case True Case UCase(Linea) = "STREAM" 'comienza a capturar datos ReDim Preserve streams(IStreams) Line Input #1, Linea Linea = Trim(Linea) capturando = True Case UCase(Linea) = "ENDSTREAM" 'termina de capturar stream IStreams = IStreams + 1 capturando = False End Select If capturando Then streams(IStreams) = streams(IStreams) + Linea End If End If Loop Close #1
'el array streams ya contiene las lineas de informacion del PDF. 'Cada caracter de cada linea, estan en exresado en Hexa. Se utiliza la función Hexa2Ansi para convertirlas en ASCII.
'activar para insertar en 2 filas RowActual = ActiveCell.Row - 2 'RowActual = ActiveCell.Row - 1 'ColActual = 1 For I = 0 To IStreams - 1 Linea = Replace(streams(I), Chr(13), "") Linea = Replace(Linea, Chr(10), "") If parseTexto(Linea, retMat) > 0 Then 'con parseTexto partimos la linea J = 0 Do While J <= UBound(retMat) strAux = Hexa2Ansi(retMat(J)) 'Hexa2Ansi convierte cadena Hexa en ANSI If strAux <> "" Then strAux = Trim(strAux) If EsNuevoPedido(strAux) Then 'activar para insertar en 2 filas RowActual = RowActual + 2 'RowActual = RowActual + 1 End If bAcu = (strAux = "N° Orden:") Or (strAux = "Fecha Orden:") Or (strAux = "N° Cliente:") bAcu = bAcu Or (strAux = "Nom./Razón Soc.:") Or (strAux = "Nombre Fantasía:") Or (strAux = "Localidad:") Or (strAux = "Calle:") bAcu = bAcu Or (strAux = "N°:") Or (strAux = "Teléfono:") Or (strAux = "Horario de Visita:") Or (strAux = "Referencia de Domicilio:") bAcu = bAcu Or (strAux = "Marca y Modelo:") Or (strAux = "N° AF:") Or (strAux = "Síntoma:") Or (strAux = "Prioridad:") Or (strAux = "Reclamo:") bAcu = bAcu Or (strAux = "Descripción del Problema:") If bAcu Then NombreCampo = strAux J = J + 1 strAux = Hexa2Ansi(retMat(J)) If EsCampo(strAux) Or EsTitulo(strAux) Then 'es el siguiente campo, hay que rajar GoTo FinLoop Else 'MsgBox NombreCampo 'activar para insertar en 2 filas ret = GetColPos(NombreCampo, ColActual) 'ret = GetColPos2(NombreCampo, ColActual) If (ColActual = 5) And (ret = 0) Then 'columna de dirección (calle + alura) Pendientes.Cells(RowActual, ColActual).Value = Pendientes.Cells(RowActual, ColActual).Value + " " + Trim(strAux) ElseIf (ColActual = 2) And (ret = 0) Then 'columna de fecha strAux = Replace(strAux, ".", "/") strAux = Day(CDate(strAux)) & "-" & Month(CDate(strAux)) Pendientes.Cells(RowActual, ColActual).Value = strAux ElseIf (ColActual = 3) And (ret = 0) Then 'numero de cliente If Mid(strAux, 1, 2) = "0E" Then Pendientes.Cells(RowActual, ColActual).Value = CLng(" " + Mid(strAux, 3, 10)) Else Pendientes.Cells(RowActual, ColActual).Value = strAux End If ElseIf (ColActual = 9) And (ret = 0) Then 'Nº AF If IsNumeric(strAux) Then Pendientes.Cells(RowActual, ColActual).Value = CLng(strAux) Else Pendientes.Cells(RowActual, ColActual).Value = strAux End If ElseIf (ColActual = 1) And (ret = 0) Then 'Nº Orden If IsNumeric(strAux) Then Pendientes.Cells(RowActual, ColActual).Value = CLng(strAux) Else Pendientes.Cells(RowActual, ColActual).Value = strAux End If Else 'esta parte inserta en 2 filas strAux = AcortarValor(UCase(Trim(strAux))) If ret = 0 Then Pendientes.Cells(RowActual, ColActual).Value = Trim(strAux) Else Pendientes.Cells(RowActual + 1, ColActual).Value = Trim(strAux) End If 'strAux = AcortarValor(UCase(Trim(strAux))) 'Pendientes.Cells(RowActual, ColActual).Value = strAux End If End If End If Else MsgBox "Error en Hexa2Ansi" GoTo Salida End If J = J + 1 FinLoop: Loop End If Next I Salida: 'MsgBox "Datos cargados" End Sub
Function AcortarValor(cadena As String) As String Select Case Trim(cadena) Case "GAFA EXHIBIDORA VERT/VC / VISICOOLER" AcortarValor = "GAFA" Case "VESTFROST EXHIBIDORA/VC / VISICOOLER" AcortarValor = "VESTFROST" Case "GAFA EXHIBIDORA VERT/MV / MINI VISU" AcortarValor = "MV GAFA" Case "MINIVISU EXHIBIDORA /MV / MINI VISU" AcortarValor = "MV GAFA" Case "BEVERAGE AIR EXHIB. /VC / VISICOOLER" AcortarValor = "CONTOUR" Case "GAFA EXHIBIDORA DOBL/VD / VISICOOLER DOBL" AcortarValor = "GAFA 2P" Case "TRENTO EXHIBIDORA VE/VC / VISICOOLER" AcortarValor = "TRENTO" Case "EQUIPO GENÉRICO SIN /" AcortarValor = "GENERICO" Case "EXHIBIDORA VERTICAL /VC / VISICOOLER" AcortarValor = "TIPO VC" Case "SANTO TOME" AcortarValor = "STO. TOME" Case "SAUCE VIEJO" AcortarValor = "S. VIEJO" 'Case "URGENTE" ' AcortarValor = "U" 'Case "NORMAL" ' AcortarValor = "N" Case Else AcortarValor = cadena End Select End Function
Function GetColPos(Campo As String, ByRef Colu As Long) As Integer Select Case Campo Case "N° Orden:" Colu = 1 GetColPos = 0 Case "Fecha Orden:" Colu = 2 GetColPos = 0 Case "N° Cliente:" Colu = 3 GetColPos = 0 Case "Nom./Razón Soc.:" Colu = 4 GetColPos = 0 Case "Nombre Fantasía:" Colu = 2 GetColPos = 1 Case "Localidad:" Colu = 7 GetColPos = 0 Case "Calle:" Colu = 5 GetColPos = 0 Case "N°:" Colu = 5 GetColPos = 0 Case "Teléfono:" Colu = 3 GetColPos = 1 Case "Horario de Visita:" Colu = 6 GetColPos = 0 Case "Referencia de Domicilio:" Colu = 4 GetColPos = 1 Case "Marca y Modelo:" Colu = 8 GetColPos = 0 Case "N° AF:" Colu = 9 GetColPos = 0 Case "Síntoma:" Colu = 10 GetColPos = 0 Case "Prioridad:" Colu = 5 GetColPos = 1 Case "Reclamo:" Colu = 6 GetColPos = 1 Case "Descripción del Problema:" Colu = 7 GetColPos = 1 End Select End Function
Function GetColPos2(Campo As String, ByRef Colu As Long) As Integer Select Case Campo Case "N° Orden:" Colu = 1 GetColPos2 = 0 Case "Fecha Orden:" Colu = 2 GetColPos2 = 0 Case "N° Cliente:" Colu = 3 GetColPos2 = 0 Case "Nom./Razón Soc.:" Colu = 4 GetColPos2 = 0 Case "Nombre Fantasía:" Colu = 11 GetColPos2 = 1 Case "Localidad:" Colu = 7 GetColPos2 = 0 Case "Calle:" Colu = 5 GetColPos2 = 0 Case "N°:" Colu = 5 GetColPos2 = 0 Case "Teléfono:" Colu = 12 GetColPos2 = 1 Case "Horario de Visita:" Colu = 6 GetColPos2 = 0 Case "Referencia de Domicilio:" Colu = 13 GetColPos2 = 1 Case "Marca y Modelo:" Colu = 8 GetColPos2 = 0 Case "N° AF:" Colu = 9 GetColPos2 = 0 Case "Síntoma:" Colu = 10 GetColPos2 = 0 Case "Prioridad:" Colu = 14 GetColPos2 = 1 Case "Reclamo:" Colu = 15 GetColPos2 = 1 Case "Descripción del Problema:" Colu = 16 GetColPos2 = 1 End Select End Function
Function Hexa2Ansi(cadena As String) As String 'Convierte una cedana Hexa en ASCII Dim I As Long Dim Hexa As String Dim car As Byte Dim retCad As String
If Len(cadena) Mod 2 <> 0 Then Hexa2Ansi = "" Else retCad = "" For I = 1 To Len(cadena) Step 2 Hexa = Mid(cadena, I, 2) retCad = retCad + Chr(CByte("&H" + Hexa)) Next I End If Hexa2Ansi = retCad End Function
Function parseTexto(cadena As String, mat() As String) As Long 'Divide una linea de texto (ver ejemplo) obteniendo una cadena Hexa contenida entre < y > 'Ejemplo: 542.75 Td <304536303136333833>Tj ET 0 g BT 141.75 542.75 Td <4E6F6D2E2F52617AF36E20536F632E3A>Tj ET 0 g BT 226.75 542.75 Td <41475549525245204D4152494120414C454A414E445241>Tj ET 0 g BT 453.55 542.75 Td <4E6F6D6272652046616E746173ED613A>Tj Dim cadCopy As String Dim Inicio As Long Dim Fin As Long Dim Maxi As Long
ReDim mat(0) Maxi = -1 cadCopy = cadena Do Inicio = InStr(1, cadCopy, "<") + 1 Fin = InStr(1, cadCopy, ">") If Inicio > 1 Then Maxi = Maxi + 1 ReDim Preserve mat(Maxi) mat(Maxi) = Mid(cadCopy, Inicio, (Fin - Inicio)) End If cadCopy = Mid(cadCopy, Fin + 1, Len(cadCopy)) Loop Until Inicio = 1 parseTexto = Maxi End Function
Function EsNuevoPedido(cadena As String) As Boolean EsNuevoPedido = (cadena = "PEDIDO SERVICIO TECNICO EQUIPOS DE FRIO") End Function
Function EsCampo(cadena As String) As Boolean Dim bAcu As Boolean
bAcu = False bAcu = bAcu Or (cadena = "N° Orden:") bAcu = bAcu Or (cadena = "Fecha Orden:") bAcu = bAcu Or (cadena = "Fecha Prev. Solución:") bAcu = bAcu Or (cadena = "Técnico:") bAcu = bAcu Or (cadena = "N° Cliente:") bAcu = bAcu Or (cadena = "Nom./Razón Soc.:") bAcu = bAcu Or (cadena = "Nombre Fantasía:") bAcu = bAcu Or (cadena = "Contacto:") bAcu = bAcu Or (cadena = "Provincia:") bAcu = bAcu Or (cadena = "Localidad:") bAcu = bAcu Or (cadena = "Barrio:") bAcu = bAcu Or (cadena = "Calle:") bAcu = bAcu Or (cadena = "N°:") bAcu = bAcu Or (cadena = "Teléfono:") bAcu = bAcu Or (cadena = "Horario de Visita:") bAcu = bAcu Or (cadena = "Referencia de Domicilio:") bAcu = bAcu Or (cadena = "Tipo:") bAcu = bAcu Or (cadena = "Marca y Modelo:") bAcu = bAcu Or (cadena = "N° AF:") bAcu = bAcu Or (cadena = "N° E.C:") bAcu = bAcu Or (cadena = "Observaciones:") bAcu = bAcu Or (cadena = "Síntoma:") bAcu = bAcu Or (cadena = "Prioridad:") bAcu = bAcu Or (cadena = "Reclamo:") bAcu = bAcu Or (cadena = "Descripción del Problema:") bAcu = bAcu Or (cadena = "Fecha Visita:") bAcu = bAcu Or (cadena = "N° A.F.:") bAcu = bAcu Or (cadena = "Realizado Por:") bAcu = bAcu Or (cadena = "Tipo Falla:") bAcu = bAcu Or (cadena = "Descripción:") EsCampo = bAcu End Function
Function EsTitulo(cadena As String) As Boolean Dim bAcu As Boolean
bAcu = False bAcu = bAcu Or (cadena = "PEDIDO SERVICIO TECNICO EQUIPOS DE FRIO") bAcu = bAcu Or (cadena = "Datos Orden") bAcu = bAcu Or (cadena = "Datos Cliente") bAcu = bAcu Or (cadena = "Datos Equipo") bAcu = bAcu Or (cadena = "Datos Falla") bAcu = bAcu Or (cadena = "Datos Última Visita") EsTitulo = bAcu End Function
Function Str2Campo(strCampo As String) As String Select Case strCampo Case "N° Orden:" Str2Campo = "NumOrden" Case "Fecha Orden:" Str2Campo = "FechaOrden" Case "N° Cliente:" Str2Campo = "NumCliente" Case "Nom./Razón Soc.:" Str2Campo = "Nombre" Case "Nombre Fantasía:" Str2Campo = "Fantasia" Case "Localidad:" Str2Campo = "Localidad" Case "Calle:" Str2Campo = "Calle" Case "N°:" Str2Campo = "Altura" Case "Teléfono:" Str2Campo = "Telefono" Case "Horario de Visita:" Str2Campo = "HorarioVisita" Case "Referencia de Domicilio:" Str2Campo = "RefDomicilio" Case "Marca y Modelo:" Str2Campo = "MarcaYModelo" Case "N° AF:" Str2Campo = "NumAF" Case "Síntoma:" Str2Campo = "Sintoma" Case "Prioridad:" Str2Campo = "Prioridad" Case "Reclamo:" Str2Campo = "Reclamo" Case "Descripción del Problema:" Str2Campo = "DescribeProblema" End Select End Function
Espero te sea útil... Saludos!
|
|
|
En línea
|
MCKSys Argentina "Si piensas que algo está bien sólo porque todo el mundo lo cree, no estás pensando."
|
|
|
AmadeoIsaboya
Desconectado
Mensajes: 3
|
Este es el código que hice (hace un tiempo ya) para "levantar" PDF's. Está diseñado para trabajar en Excel, pero cambiando un par de cosillas, anda en Word. Private Sub Command1_Click() Dim Pendientes As Worksheet Dim Linea As String Dim strAux As String Dim retMat() As String Dim streams() As String Dim IStreams As Long Dim capturando As Boolean Dim I As Long Dim J As Long Dim RowActual As Long Dim ColActual As Long Dim bAcu As Boolean Dim NombreCampo As String Dim cmdLine As String
Linea = "Está por importar datos de un PDF." + vbCrLf Linea = Linea + "Debe tener seleccionada la celda desde la cual se insertarán las nuevas celdas importadas." + vbCrLf Linea = Linea + "(La celda inical debe estar, preferentemente, al final de todas las anteriores)" + vbCrLf Linea = Linea + "¿ Ha seleccionado esta celda inicial ?" ret = MsgBox(Linea, vbQuestion + vbYesNo + vbDefaultButton1, "Atención") If ret <> vbYes Then Exit Sub
cmdLine = Application.GetOpenFileName("Archivos PDF (*.pdf),*.pdf", 1, "Abrir PDF", , False) If Dir(cmdLine) = "" Then Exit Sub
Set Pendientes = Worksheets("PENDIENTES2") 'Abre PDF para leer por lineas Open cmdLine For Input Access Read As #1 IStreams = 0 capturando = False Do While Not EOF(1) Line Input #1, Linea Linea = Trim(Linea) If Linea <> "" Then Select Case True Case UCase(Linea) = "STREAM" 'comienza a capturar datos ReDim Preserve streams(IStreams) Line Input #1, Linea Linea = Trim(Linea) capturando = True Case UCase(Linea) = "ENDSTREAM" 'termina de capturar stream IStreams = IStreams + 1 capturando = False End Select If capturando Then streams(IStreams) = streams(IStreams) + Linea End If End If Loop Close #1
'el array streams ya contiene las lineas de informacion del PDF. 'Cada caracter de cada linea, estan en exresado en Hexa. Se utiliza la función Hexa2Ansi para convertirlas en ASCII.
'activar para insertar en 2 filas RowActual = ActiveCell.Row - 2 'RowActual = ActiveCell.Row - 1 'ColActual = 1 For I = 0 To IStreams - 1 Linea = Replace(streams(I), Chr(13), "") Linea = Replace(Linea, Chr(10), "") If parseTexto(Linea, retMat) > 0 Then 'con parseTexto partimos la linea J = 0 Do While J <= UBound(retMat) strAux = Hexa2Ansi(retMat(J)) 'Hexa2Ansi convierte cadena Hexa en ANSI If strAux <> "" Then strAux = Trim(strAux) If EsNuevoPedido(strAux) Then 'activar para insertar en 2 filas RowActual = RowActual + 2 'RowActual = RowActual + 1 End If bAcu = (strAux = "N° Orden:") Or (strAux = "Fecha Orden:") Or (strAux = "N° Cliente:") bAcu = bAcu Or (strAux = "Nom./Razón Soc.:") Or (strAux = "Nombre Fantasía:") Or (strAux = "Localidad:") Or (strAux = "Calle:") bAcu = bAcu Or (strAux = "N°:") Or (strAux = "Teléfono:") Or (strAux = "Horario de Visita:") Or (strAux = "Referencia de Domicilio:") bAcu = bAcu Or (strAux = "Marca y Modelo:") Or (strAux = "N° AF:") Or (strAux = "Síntoma:") Or (strAux = "Prioridad:") Or (strAux = "Reclamo:") bAcu = bAcu Or (strAux = "Descripción del Problema:") If bAcu Then NombreCampo = strAux J = J + 1 strAux = Hexa2Ansi(retMat(J)) If EsCampo(strAux) Or EsTitulo(strAux) Then 'es el siguiente campo, hay que rajar GoTo FinLoop Else 'MsgBox NombreCampo 'activar para insertar en 2 filas ret = GetColPos(NombreCampo, ColActual) 'ret = GetColPos2(NombreCampo, ColActual) If (ColActual = 5) And (ret = 0) Then 'columna de dirección (calle + alura) Pendientes.Cells(RowActual, ColActual).Value = Pendientes.Cells(RowActual, ColActual).Value + " " + Trim(strAux) ElseIf (ColActual = 2) And (ret = 0) Then 'columna de fecha strAux = Replace(strAux, ".", "/") strAux = Day(CDate(strAux)) & "-" & Month(CDate(strAux)) Pendientes.Cells(RowActual, ColActual).Value = strAux ElseIf (ColActual = 3) And (ret = 0) Then 'numero de cliente If Mid(strAux, 1, 2) = "0E" Then Pendientes.Cells(RowActual, ColActual).Value = CLng(" " + Mid(strAux, 3, 10)) Else Pendientes.Cells(RowActual, ColActual).Value = strAux End If ElseIf (ColActual = 9) And (ret = 0) Then 'Nº AF If IsNumeric(strAux) Then Pendientes.Cells(RowActual, ColActual).Value = CLng(strAux) Else Pendientes.Cells(RowActual, ColActual).Value = strAux End If ElseIf (ColActual = 1) And (ret = 0) Then 'Nº Orden If IsNumeric(strAux) Then Pendientes.Cells(RowActual, ColActual).Value = CLng(strAux) Else Pendientes.Cells(RowActual, ColActual).Value = strAux End If Else 'esta parte inserta en 2 filas strAux = AcortarValor(UCase(Trim(strAux))) If ret = 0 Then Pendientes.Cells(RowActual, ColActual).Value = Trim(strAux) Else Pendientes.Cells(RowActual + 1, ColActual).Value = Trim(strAux) End If 'strAux = AcortarValor(UCase(Trim(strAux))) 'Pendientes.Cells(RowActual, ColActual).Value = strAux End If End If End If Else MsgBox "Error en Hexa2Ansi" GoTo Salida End If J = J + 1 FinLoop: Loop End If Next I Salida: 'MsgBox "Datos cargados" End Sub
Function AcortarValor(cadena As String) As String Select Case Trim(cadena) Case "GAFA EXHIBIDORA VERT/VC / VISICOOLER" AcortarValor = "GAFA" Case "VESTFROST EXHIBIDORA/VC / VISICOOLER" AcortarValor = "VESTFROST" Case "GAFA EXHIBIDORA VERT/MV / MINI VISU" AcortarValor = "MV GAFA" Case "MINIVISU EXHIBIDORA /MV / MINI VISU" AcortarValor = "MV GAFA" Case "BEVERAGE AIR EXHIB. /VC / VISICOOLER" AcortarValor = "CONTOUR" Case "GAFA EXHIBIDORA DOBL/VD / VISICOOLER DOBL" AcortarValor = "GAFA 2P" Case "TRENTO EXHIBIDORA VE/VC / VISICOOLER" AcortarValor = "TRENTO" Case "EQUIPO GENÉRICO SIN /" AcortarValor = "GENERICO" Case "EXHIBIDORA VERTICAL /VC / VISICOOLER" AcortarValor = "TIPO VC" Case "SANTO TOME" AcortarValor = "STO. TOME" Case "SAUCE VIEJO" AcortarValor = "S. VIEJO" 'Case "URGENTE" ' AcortarValor = "U" 'Case "NORMAL" ' AcortarValor = "N" Case Else AcortarValor = cadena End Select End Function
Function GetColPos(Campo As String, ByRef Colu As Long) As Integer Select Case Campo Case "N° Orden:" Colu = 1 GetColPos = 0 Case "Fecha Orden:" Colu = 2 GetColPos = 0 Case "N° Cliente:" Colu = 3 GetColPos = 0 Case "Nom./Razón Soc.:" Colu = 4 GetColPos = 0 Case "Nombre Fantasía:" Colu = 2 GetColPos = 1 Case "Localidad:" Colu = 7 GetColPos = 0 Case "Calle:" Colu = 5 GetColPos = 0 Case "N°:" Colu = 5 GetColPos = 0 Case "Teléfono:" Colu = 3 GetColPos = 1 Case "Horario de Visita:" Colu = 6 GetColPos = 0 Case "Referencia de Domicilio:" Colu = 4 GetColPos = 1 Case "Marca y Modelo:" Colu = 8 GetColPos = 0 Case "N° AF:" Colu = 9 GetColPos = 0 Case "Síntoma:" Colu = 10 GetColPos = 0 Case "Prioridad:" Colu = 5 GetColPos = 1 Case "Reclamo:" Colu = 6 GetColPos = 1 Case "Descripción del Problema:" Colu = 7 GetColPos = 1 End Select End Function
Function GetColPos2(Campo As String, ByRef Colu As Long) As Integer Select Case Campo Case "N° Orden:" Colu = 1 GetColPos2 = 0 Case "Fecha Orden:" Colu = 2 GetColPos2 = 0 Case "N° Cliente:" Colu = 3 GetColPos2 = 0 Case "Nom./Razón Soc.:" Colu = 4 GetColPos2 = 0 Case "Nombre Fantasía:" Colu = 11 GetColPos2 = 1 Case "Localidad:" Colu = 7 GetColPos2 = 0 Case "Calle:" Colu = 5 GetColPos2 = 0 Case "N°:" Colu = 5 GetColPos2 = 0 Case "Teléfono:" Colu = 12 GetColPos2 = 1 Case "Horario de Visita:" Colu = 6 GetColPos2 = 0 Case "Referencia de Domicilio:" Colu = 13 GetColPos2 = 1 Case "Marca y Modelo:" Colu = 8 GetColPos2 = 0 Case "N° AF:" Colu = 9 GetColPos2 = 0 Case "Síntoma:" Colu = 10 GetColPos2 = 0 Case "Prioridad:" Colu = 14 GetColPos2 = 1 Case "Reclamo:" Colu = 15 GetColPos2 = 1 Case "Descripción del Problema:" Colu = 16 GetColPos2 = 1 End Select End Function
Function Hexa2Ansi(cadena As String) As String 'Convierte una cedana Hexa en ASCII Dim I As Long Dim Hexa As String Dim car As Byte Dim retCad As String
If Len(cadena) Mod 2 <> 0 Then Hexa2Ansi = "" Else retCad = "" For I = 1 To Len(cadena) Step 2 Hexa = Mid(cadena, I, 2) retCad = retCad + Chr(CByte("&H" + Hexa)) Next I End If Hexa2Ansi = retCad End Function
Function parseTexto(cadena As String, mat() As String) As Long 'Divide una linea de texto (ver ejemplo) obteniendo una cadena Hexa contenida entre < y > 'Ejemplo: 542.75 Td <304536303136333833>Tj ET 0 g BT 141.75 542.75 Td <4E6F6D2E2F52617AF36E20536F632E3A>Tj ET 0 g BT 226.75 542.75 Td <41475549525245204D4152494120414C454A414E445241>Tj ET 0 g BT 453.55 542.75 Td <4E6F6D6272652046616E746173ED613A>Tj Dim cadCopy As String Dim Inicio As Long Dim Fin As Long Dim Maxi As Long
ReDim mat(0) Maxi = -1 cadCopy = cadena Do Inicio = InStr(1, cadCopy, "<") + 1 Fin = InStr(1, cadCopy, ">") If Inicio > 1 Then Maxi = Maxi + 1 ReDim Preserve mat(Maxi) mat(Maxi) = Mid(cadCopy, Inicio, (Fin - Inicio)) End If cadCopy = Mid(cadCopy, Fin + 1, Len(cadCopy)) Loop Until Inicio = 1 parseTexto = Maxi End Function
Function EsNuevoPedido(cadena As String) As Boolean EsNuevoPedido = (cadena = "PEDIDO SERVICIO TECNICO EQUIPOS DE FRIO") End Function
Function EsCampo(cadena As String) As Boolean Dim bAcu As Boolean
bAcu = False bAcu = bAcu Or (cadena = "N° Orden:") bAcu = bAcu Or (cadena = "Fecha Orden:") bAcu = bAcu Or (cadena = "Fecha Prev. Solución:") bAcu = bAcu Or (cadena = "Técnico:") bAcu = bAcu Or (cadena = "N° Cliente:") bAcu = bAcu Or (cadena = "Nom./Razón Soc.:") bAcu = bAcu Or (cadena = "Nombre Fantasía:") bAcu = bAcu Or (cadena = "Contacto:") bAcu = bAcu Or (cadena = "Provincia:") bAcu = bAcu Or (cadena = "Localidad:") bAcu = bAcu Or (cadena = "Barrio:") bAcu = bAcu Or (cadena = "Calle:") bAcu = bAcu Or (cadena = "N°:") bAcu = bAcu Or (cadena = "Teléfono:") bAcu = bAcu Or (cadena = "Horario de Visita:") bAcu = bAcu Or (cadena = "Referencia de Domicilio:") bAcu = bAcu Or (cadena = "Tipo:") bAcu = bAcu Or (cadena = "Marca y Modelo:") bAcu = bAcu Or (cadena = "N° AF:") bAcu = bAcu Or (cadena = "N° E.C:") bAcu = bAcu Or (cadena = "Observaciones:") bAcu = bAcu Or (cadena = "Síntoma:") bAcu = bAcu Or (cadena = "Prioridad:") bAcu = bAcu Or (cadena = "Reclamo:") bAcu = bAcu Or (cadena = "Descripción del Problema:") bAcu = bAcu Or (cadena = "Fecha Visita:") bAcu = bAcu Or (cadena = "N° A.F.:") bAcu = bAcu Or (cadena = "Realizado Por:") bAcu = bAcu Or (cadena = "Tipo Falla:") bAcu = bAcu Or (cadena = "Descripción:") EsCampo = bAcu End Function
Function EsTitulo(cadena As String) As Boolean Dim bAcu As Boolean
bAcu = False bAcu = bAcu Or (cadena = "PEDIDO SERVICIO TECNICO EQUIPOS DE FRIO") bAcu = bAcu Or (cadena = "Datos Orden") bAcu = bAcu Or (cadena = "Datos Cliente") bAcu = bAcu Or (cadena = "Datos Equipo") bAcu = bAcu Or (cadena = "Datos Falla") bAcu = bAcu Or (cadena = "Datos Última Visita") EsTitulo = bAcu End Function
Function Str2Campo(strCampo As String) As String Select Case strCampo Case "N° Orden:" Str2Campo = "NumOrden" Case "Fecha Orden:" Str2Campo = "FechaOrden" Case "N° Cliente:" Str2Campo = "NumCliente" Case "Nom./Razón Soc.:" Str2Campo = "Nombre" Case "Nombre Fantasía:" Str2Campo = "Fantasia" Case "Localidad:" Str2Campo = "Localidad" Case "Calle:" Str2Campo = "Calle" Case "N°:" Str2Campo = "Altura" Case "Teléfono:" Str2Campo = "Telefono" Case "Horario de Visita:" Str2Campo = "HorarioVisita" Case "Referencia de Domicilio:" Str2Campo = "RefDomicilio" Case "Marca y Modelo:" Str2Campo = "MarcaYModelo" Case "N° AF:" Str2Campo = "NumAF" Case "Síntoma:" Str2Campo = "Sintoma" Case "Prioridad:" Str2Campo = "Prioridad" Case "Reclamo:" Str2Campo = "Reclamo" Case "Descripción del Problema:" Str2Campo = "DescribeProblema" End Select End Function
Espero te sea útil... Saludos! Muchas gracias por tu aporte y por tu pronta respuesta.
|
|
|
En línea
|
|
|
|
|
Mensajes similares |
|
Asunto |
Iniciado por |
Respuestas |
Vistas |
Último mensaje |
|
|
Buscar en un fichero cadenas de caracteres y reemplazarlas en otro.
Programación General
|
malocha
|
5
|
5,842
|
11 Agosto 2011, 19:57 pm
por Valkyr
|
|
|
[Duda] Buscar una palabra en un texto y reemplazar lo siguiente...
Programación Visual Basic
|
Hurubnar
|
4
|
5,292
|
31 Agosto 2011, 19:40 pm
por Hurubnar
|
|
|
Buscar y reemplazar palabra en archivo
Programación C/C++
|
fran7385
|
3
|
5,002
|
28 Enero 2014, 22:47 pm
por ivancea96
|
|
|
Función buscar - reemplazar
Programación C/C++
|
Pool9
|
1
|
1,699
|
4 Mayo 2018, 20:29 pm
por Serapis
|
|
|
Esta función de Word te permite reemplazar palabras automáticamente
Noticias
|
El_Andaluz
|
0
|
2,116
|
24 Enero 2023, 21:56 pm
por El_Andaluz
|
|