Jump to content

qwerty123

Members
  • Content Count

    124
  • Joined

  • Last visited

  • Days Won

    1

qwerty123 last won the day on June 17

qwerty123 had the most liked content!

About qwerty123

  • Rank
    Advanced Member
  • Birthday 07/03/1980

Recent Profile Visitors

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

  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. Antes de "Cells.Find..." escribe: "On Error Resume Next" para evitar que se detenga por el error. Prueba el siguiente código. Lo he retocado un poco porque con el original, supongo que lo obtendrías de la grabadora de macros, me estaba perdiendo. Private Sub NuevoCambioEstado() Dim rTotal As Range Dim sCab1(1 To 11) As String Dim iCab As Integer Dim lFila As Long With Range("B1:B5") .Copy With .Offset(, 1) .PasteSpecial xlPasteAll .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom With .Font .Size = 12 .Bold = True End With For lFila = 1 To .Rows.Count .Cells(lFila, 1) = Trim(.Cells(lFila, 1)) Next .Resize(, 5).Merge True End With End With Columns("B:B").Clear With Columns("C:C") .ColumnWidth = 60 .IndentLevel = 1 End With With Columns("D:G") .ColumnWidth = 15 .NumberFormat = "#,##0" End With With Range("C8:G8") .BorderAround LineStyle:=xlDouble, Weight:=xlThick .Borders(xlInsideVertical).LineStyle = xlContinuous .VerticalAlignment = xlCenter .HorizontalAlignment = xlCenter .WrapText = True With .Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent1 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With .Font.Bold = True End With With Range([C10], Cells(Rows.Count, 3).End(xlUp)).Resize(, 5) .BorderAround LineStyle:=xlDouble, Weight:=xlThick .Borders(xlInsideHorizontal).LineStyle = xlContinuous .Borders(xlInsideVertical).LineStyle = xlContinuous For lFila = 1 To .Rows.Count .Cells(lFila, 1) = Trim(.Cells(lFila, 1)) Next sCab1(1) = "ACTIVO A CORTO PLAZO" sCab1(2) = "ACTIVO A LARGO PLAZO" sCab1(3) = "PASIVO A CORTO PLAZO" sCab1(4) = "CAPITAL" sCab1(5) = "TOTAL ACTIVO A CORTO PLAZO :" sCab1(6) = "TOTAL ACTIVO A LARGO PLAZO :" sCab1(7) = "TOTAL PASIVO A CORTO PLAZO :" sCab1(8) = "TOTAL ACTIVO :" sCab1(9) = "TOTAL PASIVO :" sCab1(10) = "TOTAL CAPITAL :" sCab1(11) = "TOTAL PASIVO + CAPITAL :" For iCab = 1 To UBound(sCab1) Set rTotal = Nothing On Error Resume Next Set rTotal = .Cells.Find(What:=sCab1(iCab), LookAt:=xlWhole) On Error GoTo 0 If Not rTotal Is Nothing Then With rTotal.Resize(, 5) .Font.Bold = True If iCab > 4 Then .BorderAround LineStyle:=xlDouble, Weight:=xlThick With .Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent1 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With .IndentLevel = 2 - (iCab > 7) End If End With End If Next End With MsgBox "Estado de Cambios Generado", vbInformation, "TERMINADO" End Sub Un saludo.
  7. Hola. El archivo sin extensión es un documento Postcript, el lenguaje que usan muchas impresoras para imprimir. Añade la extensión .ps y seguramente lo podrás abrir con Adobe Acrobat (no sé si con el Reader también, no lo tengo y no puedo probarlo). Desde este programa lo puedes exportar a una hoja excel, como texto no creo que pueda usarse. También hay páginas web que lo pueden convertir, aunque el resultado no me acaba de convencer (ver fichero .txt) Adjunto los resultados que arroja, por si te pueden servir. Un saludo. getjobid1945252.xlsx getjobid1945252.pdf getjobid1945252.ps getjobid1945252.txt
  8. 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.
  9. 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
  10. Hola. Prueba con este código: Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim iCont As Integer With Range("I" & Target.Row) iCont = .Value - 1 * ((Target.Column = 13) - (Target.Column = 15)) .Value = IIf(iCont > 3, 1, IIf(iCont < 1, 3, iCont)) End With Cancel = True End Sub Cuando el contador llegue a cero, vuelve a introducir un 3. Si no quieres que esto ocurra, cambia " IIF(iCont < 1, 3, iCont)" por "iCont". Un saludo.
  11. Hola. Podrías utilizar algo como esto: Private Sub CopiarImagen() Dim wshojas As Worksheet Dim shImag As Shape Dim sngX, sngY As Single With ActiveSheet.Shapes(1) .Copy sngY = .Top sngX = .Left End With For Each wshojas In ThisWorkbook.Sheets With wshojas If .Name <> ActiveSheet.Name Then .PasteSpecial With .Shapes(1) .Left = sngX .Top = sngY End With End If End With Next End Sub Para que funcione este código hay que tener en cuenta que se debe ejecutar siendo la hoja activa la que contiene la imágen, que sólo haya a una imágen, forma, etc. en esta hoja y que el resultado debe estar en la misma posición que la original. En otro caso, tendrás que adaptarlo a tus necesidades. Un saludo. Un saludo.
  12. Hola. Si he entendido bien lo que pides, puede que te sirva el archivo adjunto. Un saludo. bingo.xlsm
  13. Hola. También lo puedes intentar con: Sub Borrar() Dim r As Range Dim col As Long Dim lc As Long lc = Cells(1, Columns.Count).End(xlToLeft).Column For col = 1 To lc Set r = Cells(1, col).MergeArea If Len(r.Cells(1, 1)) > 3 Then r.ClearContents col = col + r.Columns.Count - 1 Next End Sub He cambiado la condición porque tal y como está la original, borraría todas las celdas y supongo que sólo debe hacerlo si tienen más de 3 caractéres. Un saludo.
  14. Hola. Si he entendido bien el problema, podrías utilizar el siguiente código: Private Sub Compl00() Dim lF As Long Dim lP As Long Dim sD As String With Cells(1, 1).CurrentRegion For lF = 2 To .Rows.Count If .Cells(lF, 1) Like "*-00" Then If sD <> "" Then .Cells(lP, 2) = Left(sD, Len(sD) - 2) sD = "" End If lP = lF Else If .Cells(lP, 2) = "" Then 'Si se tienen en cuenta las celdas en blanco: sD = sD & .Cells(lF, 2) & ", " 'Si se quieren evitar, eliminar la anterior y quitar el comentario a esta: 'If Trim(.Cells(lF, 2)) <> "" Then sD = sD & .Cells(lF, 2) & ", " End If End If Next If .Cells(lP, 2) = "" Then .Cells(lP, 2) = Left(sD, Len(sD) - 2) End With End Sub Un saludo. Prueba.xlsm
  15. Hola. Cuando se abre un archivo directamente desde el correo, se crea una copia del mismo en algún directorio. Si previamente se abrió un fichero con ese mismo nombre y no se borró, al nuevo se le añade un número para no sobreescribir el anterior. Creo que este es el problema. Yo intentaría resolverlo cambiando Workbooks("EOD Mayo V2.xlsm").Activate por ThisWorkbook.Activate. Así no importa el nombre que tenga, o le hayan puesto, siempre estará haciendo referencia a este archivo. Un saludo.
×
×
  • Create New...

Important Information

Privacy Policy