Jump to content

qwerty123

Members
  • Posts

    124
  • Joined

  • Last visited

  • Days Won

    1

qwerty123 last won the day on June 17 2020

qwerty123 had the most liked content!

About qwerty123

  • Birthday 07/03/1980

Recent Profile Visitors

The recent visitors block is disabled and is not being shown to other users.

qwerty123's Achievements

  1. Hola. Prueba con el siguiente código: Sub DescargarAdjuntos() Dim olApp As Outlook.Application Dim olExpl As Outlook.Explorer Dim olSel As Outlook.Selection Dim olMail As Outlook.MailItem Dim olAdj As Outlook.Attachment Dim iÍnd As Integer Dim sUbic As String Dim lArc As Long sUbic = ThisWorkbook.Path & "\OFERTAS\" Set olApp = GetObject(, "Outlook.application") Set olExpl = olApp.ActiveExplorer Set olSel = olExpl.Selection On Error Resume Next For Each olMail In olSel If olMail.Class = 43 Then For Each olAdj In olMail.Attachments olAdj.SaveAsFile sUbic & olAdj.Filename lArc = lArc + 1 Next End If Next On Error GoTo 0 MsgBox "Se han guardado " & Format(lArc, "#,##0") & " ficheros.", vbInformation, "TERMINADO" End Sub Hay que tener en cuenta que Outlook entiende por adjunto todo lo que no es texto. Por ejemplo, si el correo tiene una o varias imágenes, como puede ser el logotipo de la empresa, éstas se consideran también adjuntos y por lo tanto también las descargará. Por esta razón, quizá deberías considerar filtrar el tipo de archivo (excel, pdf, etc). Un saludo. PS. En el código anterior no está contemplado que correos distintos tengan adjuntos con el mismo nombre. Si se diera el caso, habría que modificarlo para que no se sobreescriban.
  2. Hola. Podrías utilizar algo parecido a esto, modificando las líneas necesarias para que se adapten a tus necesidades: Sub Macro1() Dim wkAct As Workbook Dim wkNvo As Workbook Dim wsHoja As Worksheet Dim iÍnd As Integer Set wkAct = ThisWorkbook For Each wsHoja In wkAct.Sheets If wsHoja.Name <> "Tablas" Then iÍnd = iÍnd + 1 wsHoja.Copy Set wkNvo = ActiveWorkbook wkAct.Sheets("Tablas").Copy After:=wkNvo.Sheets(1) wkNvo.SaveAs "Libro" & iÍnd & ".xlsx" wkNvo.Close End If Next End Sub Un saludo.
  3. Hola. Prueba con esto: Sub SendData() Dim Enviado As String Dim Http As String Http = "https://sandbox.checkout.payulatam.com/ppp-web-gateway-payu" Enviado = Replace( _ "?merchantId=" & "508029" & _ "&accountId=" & "512321" & _ "&description=" & "Test Pago" & _ "&referenceCode=" & "TestPago" & _ "&amount=" & "20000" & _ "&tax=" & "0" & _ "&taxReturnBase=" & "0" & _ "&currency=" & "COP" & _ "&signature=" & "7ace3c4c2ce3e343f462cfe1b9159f5f", _ " ", "+") ThisWorkbook.FollowHyperlink Http & Enviado End Sub Un saludo.
  4. Hola. Por si sirve de algo, para calcular el ángulo en función de la pendiente: =GRADOS(ATAN(pendiente/100)) Un saludo.
  5. Hola. Cuando la selección es múltiple no puedes utilizar la propiedad Value para obtener los resultados. En este caso te recomiendo cambiar todo "List_Cta.Value" por "List_Cta.List(i)". Un saludo.
  6. Hola. Cambia la línea que da error por la siguiente y nos dices: .Offset(, 6).FormulaLocal = "=SUMA(" & VBA.Left(sTot, VBA.Len(sTot) - 1) & ")" Un saludo.
  7. Hola. Comprueba el adjunto para ver si es lo que quieres. Nota: La macro está hecha suponiendo que la disposición de los datos es como en el archivo que has pasado, el separador de argumentos es el punto y coma y el idioma el español. Si no fuera así y diera problemas en alguno de los dos últimos casos, adapta las siguientes líneas a lo que corresponda: sTot = sTot & .Cells(lClFin + 1, 7).Address(True, False) & ";" .Offset(, 6).FormulaLocal = "=SUMA(" & Left(sTot, Len(sTot) - 1) & ")" Un saludo. CLIENTES.xlsm
  8. Hola. Aunque ya veo que resolviste el problema y que RORO1981 también te ha dado otra opción, te dejo la mia. La hice antes de ver las soluciones. Un saludo. seguimiento1.2.zip
  9. Hola. El código anterior, al menos el que te he pasado, no bloquea ni desbloquea ninguna celda, tan sólo protege la hoja, es decir, para toda celda que quieras que sea accesible deberás desmarcar la casilla "Bloqueada" en "Proteger" dentro de su "Formato de celda". Y, obviamente, marcarla para todas la que debas proteger. Pero esto hay que hacerlo antes de utilizar la hoja. Espero que esto te sirva. Un saludo.
  10. Hola. El siguiente código está modificado para que sólo se muestren resultados según los criterios que estén cubiertos. He puesto la clave abc para proteger la hoja. Cámbiala por la que corresponda o si no debe tener, elimina la parte de la instrucción que está marcada en rojo: Private Sub cmdimportar_Click() Dim sError As String Dim ruta As String Dim base_de_datos As String Dim tabla As String Dim celda_inicial As String Dim i As Integer Dim sWSQL As String ruta = ThisWorkbook.Path base_de_datos = "Reporte_datos_exportados.mdb" tabla = "Reporte_Diario" celda_inicial = "a10" '************************************************** 'Ocultamos el procedimiento Application.ScreenUpdating = False ActiveSheet.Protect [COLOR=red]Password:="abc",[/COLOR] UserInterfaceOnly:=True 'Capturamos los posibles errores On Error GoTo HayError 'Creamos el objeto conexión sError = "No se ha podido abrir la base de datos." Set Conn = New ADODB.Connection 'Nos conectamos a la base de datos Conn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & ruta & "\" & base_de_datos) 'Montamos la sentencia SQL para 'mostrar todos los datos de la tabla total_filas = Rows.Count - Range(celda_inicial).Row Sql = "Select * from " & tabla If Range("H7") <> "" And Range("H5") = "" Then Range("H5") = Range("H7") Range("H7") = "" End If If Range("H5") <> "" Then If Range("H7") <> "" Then sWSQL = "(Fecha_exportado BETWEEN " & _ CLng(Range("H5")) & " AND " & CLng(Range("H7")) & ")" Else sWSQL = "(Fecha_exportado = " & CLng(Range("H5")) & ")" End If End If If Range("E5") <> "" Then sWSQL = sWSQL & IIf(sWSQL <> "", " AND", "") & " (Identificacion = """ & Range("E5") & """)" End If If Range("E7") <> "" Then sWSQL = sWSQL & IIf(sWSQL <> "", " AND", "") & " (Numero_solicitud = """ & Range("E7") & """)" End If Sql = Sql & IIf(sWSQL <> "", " WHERE (" & sWSQL & ")", "") 'Abrimos la base de datos 'Creamos el objeto recordset sError = "Hay problemas con la tabla " & tabla & " de la base de datos" Set rs = New ADODB.Recordset rs.Open Sql, Conn, adOpenStatic, adLockOptimistic 'BORRAMOS LOS POSIBLES DATOS ANTERIORES Range(celda_inicial).CurrentRegion.ClearContents 'Títulos de las columnas With Range(celda_inicial) For i = 0 To rs.Fields.Count - 1 .Offset(, i) = UCase(rs.Fields(i).Name) Next .CurrentRegion.Font.Bold = True End With 'contamos los registros totales registros_totales = rs.RecordCount If registros_totales = 0 Then sError = "No hay registros para estos criterios" Error 65535 End If 'Copiar el resultado sError = "Hay problemas para grabar los datos en la hoja." With Range(celda_inicial).Offset(1) .CopyFromRecordset rs, total_filas End With sError = "" 'cerramos la conexión Conn.Close 'limpiamos los objetos Set Conn = Nothing Set rs = Nothing 'Mostramos el procedimiento Application.ScreenUpdating = True 'Resultado de la importación HayError: Application.ScreenUpdating = True If sError = "" Then If registros_totales <= total_filas Then sError = " Se importaron correctamente todos los registros " & _ Chr(13) & " de la base de datos """ & base_de_datos & """, y de la tabla " & _ Chr(13) & " llamada """ & tabla & """. " & _ Chr(13) & Chr(13) & " Se han importado los " & registros_totales & " registros de la tabla. " & _ Chr(13) & Chr(13) Else sError = " Se importaron correctamente solo algunos registros " & _ Chr(13) & " de la base de datos """ & base_de_datos & """, y de la tabla " & _ Chr(13) & " llamada """ & tabla & """. " & _ Chr(13) & Chr(13) & " En concreto solo se importaron " & total_filas & " registros, de " & _ Chr(13) & " los " & registros_totales & " registros disponibles. " & _ Chr(13) & Chr(13) End If End If MsgBox Chr(13) & sError, vbOKOnly, "TERMINADO" End Sub [/CODE] He procurado dejar lo más posible el código original, aunque opino que se debería replantear la lógica del procedimiento. Un saludo.
  11. Hola. He modificado un poco el código para que tenga en cuenta si hay o no criterios de búsqueda. Private Sub cmdimportar_Click() Dim sError As String Dim ruta As String Dim base_de_datos As String Dim tabla As String Dim celda_inicial As String Dim i As Integer Dim sWSQL As String ruta = ThisWorkbook.Path base_de_datos = "Reporte_datos_exportados.mdb" tabla = "Reporte_Diario" celda_inicial = "a10" '************************************************** 'Ocultamos el procedimiento Application.ScreenUpdating = False 'Capturamos los posibles errores On Error GoTo HayError 'Creamos el objeto conexión sError = "No se ha podido abrir la base de datos." Set Conn = New ADODB.Connection 'Nos conectamos a la base de datos Conn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & ruta & "\" & base_de_datos) 'Montamos la sentencia SQL para 'mostrar todos los datos de la tabla total_filas = Rows.Count - Range(celda_inicial).Row Sql = "Select * from " & tabla If Range("H7") <> "" And Range("H5") = "" Then Range("H5") = Range("H7") Range("H7") = "" End If If Range("H5") <> "" Then If Range("H7") <> "" Then sWSQL = "(Fecha_exportado BETWEEN " & _ CLng(Range("H5")) & " AND " & CLng(Range("H7")) & ")" Else sWSQL = "(Fecha_exportado = " & CLng(Range("H5")) & ")" End If End If If Range("E5") <> "" Then sWSQL = sWSQL & " AND (Identificacion = """ & Range("E5") & """)" End If If Range("E7") <> "" Then sWSQL = sWSQL & " AND (Numero_solicitud = """ & Range("E7") & """)" End If Sql = Sql & IIf(sWSQL <> "", " WHERE (" & sWSQL & ")", "") 'Abrimos la base de datos 'Creamos el objeto recordset sError = "Hay problemas con la tabla " & tabla & " de la base de datos" Set rs = New ADODB.Recordset rs.Open Sql, Conn, adOpenStatic, adLockOptimistic 'BORRAMOS LOS POSIBLES DATOS ANTERIORES Range(celda_inicial).CurrentRegion.ClearContents 'Títulos de las columnas With Range(celda_inicial) For i = 0 To rs.Fields.Count - 1 .Offset(, i) = UCase(rs.Fields(i).Name) Next .CurrentRegion.Font.Bold = True End With 'contamos los registros totales registros_totales = rs.RecordCount If registros_totales = 0 Then sError = "No hay registros para estos criterios" Error 65535 End If 'Copiar el resultado With Range(celda_inicial).Offset(1) .CopyFromRecordset rs, total_filas End With sError = "" 'cerramos la conexión Conn.Close 'limpiamos los objetos Set Conn = Nothing Set rs = Nothing 'Mostramos el procedimiento Application.ScreenUpdating = True 'Resultado de la importación HayError: Application.ScreenUpdating = True If sError = "" Then If registros_totales <= total_filas Then sError = " Se importaron correctamente todos los registros " & _ Chr(13) & " de la base de datos """ & base_de_datos & """, y de la tabla " & _ Chr(13) & " llamada """ & tabla & """. " & _ Chr(13) & Chr(13) & " Se han importado los " & registros_totales & " registros de la tabla. " & _ Chr(13) & Chr(13) Else sError = " Se importaron correctamente solo algunos registros " & _ Chr(13) & " de la base de datos """ & base_de_datos & """, y de la tabla " & _ Chr(13) & " llamada """ & tabla & """. " & _ Chr(13) & Chr(13) & " En concreto solo se importaron " & total_filas & " registros, de " & _ Chr(13) & " los " & registros_totales & " registros disponibles. " & _ Chr(13) & Chr(13) End If End If MsgBox Chr(13) & sError, vbOKOnly, "TERMINADO" End Sub [/CODE] La mala noticia es que lo anterior no va a funcionar con tu base de datos, puesto que el campo "Fecha_exportado" que debería estar definido como Fecha/hora, lo está como Texto y la consulta siempre será errónea. Antes de hacer nada, cámbialo. Un saludo.
  12. Hola. Creo que lo más fácil es incluir las fechas dentro de la cadena SQL. Algo como lo siguiente, que para un número alto de registros iría ligeramente más rápido. Private Sub cmdimportar_Click() Dim sError As String Dim ruta As String Dim base_de_datos As String Dim tabla As String Dim celda_inicial As String Dim i As Integer ruta = ThisWorkbook.Path base_de_datos = "Reporte_datos_exportados.mdb" tabla = "Reporte_Diario" celda_inicial = "a10" '************************************************** 'Ocultamos el procedimiento Application.ScreenUpdating = False 'Capturamos los posibles errores On Error GoTo HayError 'Creamos el objeto conexión sError = "No se ha podido abrir la base de datos." Set Conn = New ADODB.Connection 'Nos conectamos a la base de datos Conn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & ruta & "\" & base_de_datos) 'Montamos la sentencia SQL para 'mostrar todos los datos de la tabla total_filas = Rows.Count - Range(celda_inicial).Row Sql = "Select * from " & tabla & " WHERE Fecha_exportado BETWEEN " & _ Format(Range("H5"), "\#mm-dd-yyyy\#") & " AND " & Format(Range("H7"), "\#mm-dd-yyyy\#") 'Abrimos la base de datos 'Creamos el objeto recordset sError = "Hay problemas con la tabla " & tabla & " de la base de datos" Set rs = New ADODB.Recordset rs.Open Sql, Conn, adOpenStatic, adLockOptimistic 'contamos los registros totales registros_totales = rs.RecordCount If registros_totales = 0 Then sError = "No hay registros para estas fechas" Error 65535 End If 'BORRAMOS LOS POSIBLES DATOS ANTERIORES Range(celda_inicial).CurrentRegion.ClearContents 'Recorremos todos los registros 'empezando a escribir en la celda A1 With Range(celda_inicial) For i = 0 To rs.Fields.Count - 1 .Offset(, i) = UCase(rs.Fields(i).Name) Next .CurrentRegion.Font.Bold = True End With 'Copiar el resultado With Range(celda_inicial).Offset(1) .CopyFromRecordset rs, total_filas End With sError = "" 'cerramos la conexión Conn.Close 'limpiamos los objetos Set Conn = Nothing Set rs = Nothing 'Mostramos el procedimiento Application.ScreenUpdating = True 'Resultado de la importación HayError: If sError = "" Then If registros_totales <= total_filas Then sError = " Se importaron correctamente todos los registros " & _ Chr(13) & " de la base de datos """ & base_de_datos & """, y de la tabla " & _ Chr(13) & " llamada """ & tabla & """. " & _ Chr(13) & Chr(13) & " Se han importado los " & registros_totales & " registros de la tabla. " & _ Chr(13) & Chr(13) Else sError = " Se importaron correctamente solo algunos registros " & _ Chr(13) & " de la base de datos """ & base_de_datos & """, y de la tabla " & _ Chr(13) & " llamada """ & tabla & """. " & _ Chr(13) & Chr(13) & " En concreto solo se importaron " & total_filas & " registros, de " & _ Chr(13) & " los " & registros_totales & " registros disponibles. " & _ Chr(13) & Chr(13) End If End If MsgBox Chr(13) & sError, vbOKOnly, "TERMINADO" End Sub[/CODE] Un saludo.
  13. Hola. Supongamos que los datos estén en A1:A20 y los números a buscar en C1 y C2: =SUMA(DESREF(A1:A20;COINCIDIR(C2;A1:A20;0);0;COINCIDIR(C1;A1:A20;0)-COINCIDIR(C2;A1:A20;0)))[/CODE] en este caso C1 siempre debe ser mayor que C2. Pero si no tiene porqué ser así, prueba con: [CODE]=SUMA(DESREF(A1:A20;COINCIDIR(MIN(C1:C2);A1:A20;0)-(C1<C2);0;COINCIDIR(MAX(C1:C2);A1:A20;0)-COINCIDIR(MIN(C1:C2);A1:A20;0)))[/CODE] Un saludo.
  14. Hola. No te funciona porque la variable "col" sólo la utilizas para generar el primer "For" pero no la vuelves a emplear más, por lo que lo único que hace es repetir varias veces lo que contiene pero de forma idéntica en todas las ocasiones. "fil = 48" está antes del "For" que hace cambiar las columnas, con lo cual esta variable fil nunca se vuelve a reiniciar hasta que se repite lo mismo, como indiqué antes. De todas formas, para mí la propuesta de Mauricio es más eficaz, quedaría algo como esto: If WorksheetFunction.CountIf(myrange, CDate(mifecha)) = 0 Or WorksheetFunction.CountIf(myrange1, CDate(mifecha1)) = 0 Then MsgBox "Revise fechas puesto que generó error de localización en hoja Alim.Rougher2009", , "" Exit Sub End If x = WorksheetFunction.Match((mifecha - dddi) + 2, myrange, 0) y = WorksheetFunction.Match((mifecha1 - dddi) + 2, myrange1, 0) [COLOR=navy]Sheets("Alim.Rougher2009").Cells(15, 48).Resize(10, y - x + 1) = _[/COLOR] [COLOR=navy] Range(Cells(35, x), Cells(44, y)).Value[/COLOR] [/CODE] Un saludo.
  15. Hola. En el adjunto encontrarás un fichero PDF obtenido de la última hoja que has pasado, aunque he tenido que reducirlo por cuestión de espacio. Las cuatro primeras líneas, he puesto la misma ref. para comparar mejor, están obtenidas de las cuatro maneras: con la macro, con la fórmula =CONCATENATE("*";Dxx;"*"), con =CONCATENATE("*" & Dxx & "*") y de la forma que utilizabas al inicio, con columnas auxiliares. No están necesariamente en este orden. ¿Podrías decirme si la pistola (o tú mismo) es capaz de distinguir cuál es la del resultado de la macro? siguiendo tu razonamiento, no podría leerla y las otras tres sí. Un saludo. Copy of Barcode.3.zip
×
×
  • Create New...

Important Information

Privacy Policy