teban_gahe

HOla John Buena tarde ..

  Muchass gracias por la ayuda con la Macro.

Mi estimado  una consulta  mas, como puedo  concatenar varias celdas en  la macro.

este es mi codigo  actual,  pero  al  presionar el Boton  Enviar,  me Duplica la copia en el Otro  archivo  y el Resultado es "0" este es el código que le anexe

 xf = wsDest.Range("A" & Rows.Count).End(xlUp).Row + 1
     For j = 0 To UBound(Orig)
      wsDest.Range(Dest(j) & xf) = wsOrigen.Range(Orig(j))      
   Next j 
   wsDest.Range("l" & xf) = Application.Sum(wsOrigen.Range("h51", "h54"))

Sub EjecutarMacros()
    Call CopiarCeldas
    Call Macro2
    Call ENVIAR_CORREO
    Call OCULTAR
End Sub

Sub CopiarCeldas()
   Dim Orig, Dest, i&, uf&, j&, xf
   Dim wbDest As Workbook
   Dim wsOrigen As Worksheet, wsDest As Worksheet
   
   Application.ScreenUpdating = False
   Orig = Array("A37", "D5", "B3", "I17", "D7", "D17", "A23", "I13", "I15", "G57")
   Dest = Array("K", "A", "C", "D", "E", "H", "J", "I", "G", "N")
   
   Set wsOrigen = Worksheets("RO_SECHU")
   Set wbDest = Workbooks.Open(ThisWorkbook.Path & "\CONTROLROSECHU.xlsx")
   Set wsDest = wbDest.Sheets("Reporte_Diario")
   
   uf = wsDest.Range("A" & Rows.Count).End(xlUp).Row + 1
   
   For i = 0 To UBound(Orig)
      wsDest.Range(Dest(i) & uf) = wsOrigen.Range(Orig(i))
      
   Next i
 
   wsDest.Range("M" & uf) = Application.Sum(wsOrigen.Range("G51:G54"))
   
   xf = wsDest.Range("A" & Rows.Count).End(xlUp).Row + 1
     For j = 0 To UBound(Orig)
      wsDest.Range(Dest(j) & xf) = wsOrigen.Range(Orig(j))
      
   Next j
 
   wsDest.Range("l" & xf) = Application.Sum(wsOrigen.Range("h51", "h54"))
     
   
   wbDest.Close True
   Set wsOrigen = Nothing: Set wbDest = Nothing: Set wsDest = Nothing
   Erase Orig, Dest
   Application.ScreenUpdating = True
End Sub
Sub Macro2()
    Range("R2").Select
    Sheets("RO_SECHU").Range("S5").Select
End Sub

Sub ENVIAR_CORREO()

'--->   desactivamos brinco de pantalla y calculo automaticos.
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
 
      
      '--->   Si no hay Datos en celda se aborta proceso
      If Range("s2") = "" Then
            MsgBox "Faltan Datos en Celda S2", vbCritical, "MODULO CORREO EXCEL"
            Exit Sub
             End If
        '--->   Si no hay Datos en celda se aborta proceso
        If Range("s3") = "" Then
            MsgBox "Faltan Datos en Celda S3", vbCritical, "MODULO CORREO EXCEL"
            Exit Sub
             End If
        '--->   Si no hay Datos en celda se aborta proceso
        If Range("s4") = "" Then
            MsgBox "Faltan Datos en Celda S4", vbCritical, "MODULO CORREO EXCEL"
            Exit Sub
             End If
        '--->   Si no hay Datos en celda se aborta proceso
        If Range("s5") = "" Then
            MsgBox "Faltan Datos en Celda S5", vbCritical, "MODULO CORREO EXCEL"
            Exit Sub
             End If
             
              '--->   Selecciona el rango de celdas que deseas copiar y enviar.
   ActiveSheet.Range("A1:K58").Select
   
   '--->   Mostrar vista previa del área seleccionada.
   ActiveWorkbook.EnvelopeVisible = True
   
   '--->   Detallamos la introduccion del correo, el correo del destinatario, la copia oculta y el asunto y enviamos.
   With ActiveSheet.MailEnvelope
      .Item.To = Range("s2").Value
      .Item.CC = Range("s3").Value
      .Item.BCC = Range("s4").Value
      .Item.Subject = Range("s5").Value
      '---> Se Envia el Correo
      .Item.Send
       End With
  ActiveWorkbook.EnvelopeVisible = False
             
'---> se lanza mensaje finalización
MsgBox "Proceso Finalizado", vbCritical, "MODULO CORREO EXCEL"

' activamos brinco de pantalla y calculo automaticos.
ActiveWorkbook.EnvelopeVisible = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
Sub OCULTAR()
'--->   se cierra vista del area de correo
ActiveWorkbook.EnvelopeVisible = False
End Sub

.RO_SECHUBackup.xlsm

CONTROLROSECHU.xlsx