Macro para cargos

[viniciusmauser]

He estado trabajando en una macro para extraer la información de 2 hojas de un libro y que la información quede en un nuevo libro y que se guarde en una carpeta. Tengo un libro donde está todo el de RIESGOS VERSION FINAL está la información que necesitamos, hay 2 hojas ahí con la que trabajaremos, SOD y Resumen X usuario, en la hoja SOD filtramos por empresa, (es importante filtrar por empresa ya que se guardará en una carpeta con el nombre de esa empresa el archivo generado) y ahí tomamos un cargo, copiamos las columnas A (CARGO), D (ID RISK), E (DES RIESGO), F (NIVEL), G (ID FUN), H (DES FUN), I (TRX), J (DES TRX) y esa info la pegamos desde la celda A2, luego copiamos el nombre del cargo en la otra hoja (Resumen x Usuario), se filtra por cargo el mismo cargo y validador de la hoja SOD copiamos los usuarios y el centro de los usuarios con ese cargo y lo pegamos en otro lado quitando luego los duplicados, copiamos el resultado y vamos a la hoja donde estamos guardando los datos del cargo, a continuación de la celda que dice la descripción de la trx presionamos botón derecho, pegado especial, seleccionamos pegado por valores y marcamos la casilla transponer, y aceptar, así se nos pegaran los valores hacia el lado, luego vemos el último usuario que se pegó con su centro y al lado de eso dejamos una celda para comentarios, en el nombre de la hoja ponemos el nombre del cargo y guardamos la planilla con el nombre del cargo en la carpeta de la empresa que filtramos al comienzo.

 

Adjunto una planilla ejemplo (Analista de respuesto) es el formato para entender lo que se necesita. y adjunto macro Libro1

 

Esto es lo que tengo en mi código:

Sub Macro1()
'
' Macro1 Macro
'
Dim x As Integer

Sheets("SOD-CARGO").Select
NumRows = Range("A2", Range("A2").End(xlDown)).Rows.Count
Range("A2").Select

' For x = 1 To NumRows
    Columns("A:A").Select
    Selection.Copy
    Sheets("CARGOS").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    NumRowsX = Range("A2", Range("A2").End(xlDown)).Rows.Count
    ActiveSheet.Range("$A$1:$A$" & NumRowsX).RemoveDuplicates Columns:=1, Header:= _
        xlYes
    Range("A2").Select
    Selection.Copy
    Sheets("SOD-CARGO").Select
    ' Range("A8").Select
    NumRowsY = Range("A2", Range("A2").End(xlDown)).Rows.Count
    ActiveSheet.Range("$A$1:$J$" & NumRowsY).AutoFilter Field:=1, Criteria1:=Array( _
        "Ingeniero Ventas Equipos"), _
        Operator:=xlFilterValues
    Range("A1:J" & NumRowsY).Select
    Range("A8").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("SOD1").Select
    Range("B1").Select
    ActiveSheet.Paste
    Range("B2").Select
    Sheets("CARGOS").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("SOD1").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[1],R1C1,1,0)"
    Range("A2").Select
    Selection.AutoFill Destination:=Range("A2:A141")
    Range("A2:A141").Select
    Range("A1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$K$141").AutoFilter Field:=1, Criteria1:= _
        "Ingeniero Ventas Equipos"
    NumRowsY = Range("A2", Range("A2").End(xlDown)).Rows.Count
    Range("A1:K" & NumRowsY).Select
    Selection.Copy
    Sheets("SOD2").Select
    Range("A2").Select
    ActiveSheet.Paste
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Rows("1:1").Select
    ' Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove '
    Range("A3").Select
    Selection.Copy
    Sheets("DATOS-USER").Select
    NumRowsZ = Range("A2", Range("A2").End(xlDown)).Rows.Count
    ActiveSheet.Range("$A$1:$H$" & NumRowsZ).AutoFilter Field:=1, Criteria1:=Array( _
        "Ingeniero Ventas Equipos"), _
        Operator:=xlFilterValues
    Range("A1:H" & NumRowsZ).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("DATOS1").Select
    ActiveSheet.Paste
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A2").Select
    Sheets("SOD2").Select
    Selection.Copy
    Sheets("DATOS1").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[1],R1C1,1,0)"
    Range("A2").Select
    NumRowsA = Range("A2", Range("A2").End(xlDown)).Rows.Count
    Selection.AutoFill Destination:=Range("A2:A" & NumRowsA)
    Range("A2:A" & NumRowsA).Select
    Range("B1").Select
    NumRowsB = Range("A2", Range("A2").End(xlDown)).Rows.Count
    Selection.AutoFilter
    
    ActiveSheet.Range("$A$1:$I$" & NumRowsB).AutoFilter Field:=1, Criteria1:= _
        "Ingeniero Ventas Equipos"
    Columns("D:E").Select
    Selection.Copy
    Sheets("DATOS2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    NumRowsC = Range("A2", Range("A2").End(xlDown)).Rows.Count
    ActiveSheet.Range("$A$1:$B$" & NumRowsC).RemoveDuplicates Columns:=Array(1, 2), _
        Header:=xlYes
    Range("A2:B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("I1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
        
    Range("I1").Select
    Sheets("SOD2").Select
    Range("I1").Select
    ActiveSheet.Paste
    
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("K2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 5296274
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("I3").Select
    ActiveCell.FormulaR1C1 = "X"
    uc = Range("A2").End(xlToRight).Column
    ActiveSheet.Cells(3, uc).Value = "X"
    NumRowsE = Range("A2", Range("A2").End(xlDown)).Rows.Count
    ActiveSheet.Cells(NumRowsE, 9).Value = "X"
    Range("I3").Select
    ActiveWindow.SmallScroll Down:=-3
    Selection.Copy
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    NumRowsD = Range("A2", Range("A2").End(xlDown)).Rows.Count
    ActiveWindow.SmallScroll Down:=NumRowsD
    Range("U67").Select
    Selection.End(xlUp).Select
    Range("S1").Select
    Selection.End(xlToLeft).Select
    Selection.End(xlToLeft).Select
    Range("A2").Select
    Selection.End(xlDown).Select
    Rows("63:63").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("L59").Select
    Selection.End(xlUp).Select
    Windows("Libro1.xlsm").Activate
    uc_2 = Range("A2").End(xlToRight).Column
    Range("A1:Y").Select
    Range("L1").Activate
    Selection.Copy
    ActiveWindow.SmallScroll Down:=12
    
    ActiveWindow.SmallScroll Down:=-3
    Windows("Libro1.xlsm").Activate
    ActiveWindow.SmallScroll Down:=-18
    Cells.Select
    Range("A37").Activate
    Application.CutCopyMode = False
    Selection.Copy
    ' Windows("prueba.xlsx").Activate '
    Range("A1").Select
    ActiveSheet.Paste
    Range("J2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.End(xlToRight).Select
    Range("Z2").Select
    ActiveSheet.Paste
    Range("Y2").Select
    Selection.End(xlToLeft).Select
    Range("Z2").Select
    Application.CutCopyMode = False
    uc_1 = Range("A2").End(xlToRight).Column
    ActiveSheet.Cells(2, uc_1 + 1).Value = "COMENTARIOS"
    ' ActiveCell.FormulaR1C1 = "COMENTARIOS"
    Cells.Select
    Range("P1").Activate
    Cells.EntireColumn.AutoFit
    Range("P2").Select
    Selection.End(xlToLeft).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    
    
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A3").Select
    Selection.Copy
    Application.CutCopyMode = False
    
    Sheets("SOD2").Select
    Cells.Select
    Selection.Copy
    Workbooks.Add.Worksheets(1).Paste
    ChDir "C:\Users\vinim\Desktop\macro"
    ActiveCell.FormulaR1C1 = "Ingeniero Ventas Equipos"
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\vinim\Desktop\macro\Ingeniero Ventas Equipos.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveCell.FormulaR1C1 = "Ingeniero Ventas Equipos"
    Sheets("Hoja1").Select
    Sheets("Hoja1").Name = "Ingeniero Ventas Equipos"
    ActiveWorkbook.Save
    ActiveWindow.SmallScroll Down:=-18
    Range("A2").Select
    ActiveWindow.Close
    Sheets("SOD1").Select
    Cells.Select
    'Range("A42").Activate'
    Selection.Delete Shift:=xlUp
    Cells.Select
    'Range("A42").Activate'
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    Sheets("SOD2").Select
    Cells.Select
    'Range("A37").Activate'
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    Sheets("DATOS1").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    ActiveWindow.SmallScroll Down:=-3
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    Sheets("DATOS2").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    Sheets("SOD1").Select
    
    ActiveCell.Offset(1, 0).Select
      ' Next
End Sub

 

 

Analista de Respuestos.xlsx

RIESGOS VERSION FINAL_OPERACIONES.xlsx Libro1.xlsm Libro1.xlsm