Incluir campos en una macro que crea una plantilla
Existe un archivo de Excel que tiene n numero de columnas. Adicional a eso tiene una macro que lo que hace es exportar esa información a un archivo nuevo.
La exportación copia dichos datos, crea una hoja y los pega.
El problema que tengo es que no cree esa macro y hay otras columnas nuevas que hay que pegar en la última posición.
Cual sería la función para incluir esas nuevas columnas si son:
Columna 1 se llama: año
Columna 2 se llama: concepto
Estas dos columnas deben insertarse al final y traer todos los campos que contengan datos, hay que tener en cuenta que habrán campos vacíos (No deben exportarse espacios en blanco) .
2 Respuestas
Esta es la macro:
Option Private Module
Option Explicit
Public Rf1aP As Range
Public Const Rff1aP As String = "A1:JZ1" 'borra WWW OK
Public Rf2aP As Range
Public Const Rff2aP As String = "A2:K2" 'rg copiar los encabezados en el nuevo Ap OK se debe reemplazar x el rango
Public Rf5aP As Range
Public Const Rff5aP As String = "A3:K5" 'rg copiar los encabezados AP OK
Public Rf7aP As Range
Public Const Rff7aP As String = "A7:JZ7" 'codConceptosAP OK
Public Const CantColumAp As Integer = -11 ' cantidad colum q vuelve a "A" para pegar desde AP
Public Const CantValCon As Integer = 36 ' cantidad colum q vvalida contenido HT
Sub CreaRngosApLano()
Set Rf1aP = Range(Rff1aP) 'rg para borrar WWW
Set Rf2aP = Range(Rff2aP) 'rg copiar los encabezados en el nuevo Ap
Set Rf5aP = Range(Rff5aP) 'rg para crear filtros
Set Rf7aP = Range(Rff7aP) 'rg para copiar codConceptosAP
End Sub
Sub CrearAPlano()
Sheets("AP").Select
Application.ScreenUpdating = False
Sheets("AP").Unprotect ClaHTws
Range("N5").FormulaR1C1 = _
"=IF(OR(R[-2]C="""",R[-2]C[1]="""",R[-2]C[4]="""",R[-2]C[5]="""",R[-2]C[7]="""",R[-2]C[8]="""",R[-2]C[2]="""",R[-2]C[3]=""""),1,0)"
If Range("N5").Value = 1 Then
MsgBox "Debe completar la información poder continuar", vbExclamation + vbOKOnly, "HT"
Range("N5").Value = ""
Sheets("AP").Protect ClaHTws
Else
Range("T3").FormulaR1C1 = _
"=""'""&RIGHT(""000000000000000""&RC[-6],15)&RIGHT(""00""&DAY(RC[-2]),2)&RIGHT(""00""&MONTH(RC[-2]),2)&YEAR(RC[-2])&RIGHT(""0000""&RC[-1],4)&RC[2]"
Nomlib = Range("T3").Value
Range("C1").Value = Nomlib
Range("N5").Value = ""
Range("T3").Value = Nomlib
Nomlib = ActiveSheet.Range("C1").Value
estLib = ThisWorkbook.Name
Hojaaa = Range("B1").Value
Windows(estLib).Activate
ValidaConten '''
If ValContHoja >= 1 Then
Else
Const ruta = "C:\HT\"
Dim Path As String, NombreCarpeta As String
Path = "C:\"
NombreCarpeta = "HT"
If Dir(Path, vbDirectory) <> "" Then
If Dir(Path & NombreCarpeta, vbDirectory) = "" Then MkDir Path & NombreCarpeta
End If
Dim NewBook As Object
Set NewBook = Workbooks.Add
With NewBook
.SaveAs ruta & Nomlib
End With
nuevLib = ActiveWorkbook.Name
Dim y As Integer, x As Integer
y = ActiveWorkbook.Sheets.Count
For x = y To Hojaaa - 1
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
Next x
Windows(estLib).Activate
Sheets("AP").Select
Range("A1").Select
nomHoja = ActiveCell.Value
Sheets(nomHoja).Select
Set Rf5aP = Range(Rff5aP) 'rg para crear filtros
Rf5aP.Select
Selection.Copy
Windows(nuevLib).Activate
Sheets("Hoja1").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Windows(estLib).Activate
Set Rf7aP = Range(Rff7aP) 'rg para copiar codConceptosAP
Rf7aP.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows(nuevLib).Activate
Range("K1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Range("A2").EntireRow.Delete
Set Rf1aP = Range(Rff1aP) 'rg para borrar WWW
Rf1aP.Select
Selection.Replace What:="www", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Rf1aP.Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireColumn.Delete
Range("A1").Select
ActiveSheet.Name = Range("A2").Value
Dim VuEl As Integer
VuEl = 0
If Range("K1").Value > 0 Then FilExport = 1
If Range("K2").Value > 0 Then FilExport = 2
If Range("K3").Value > 0 Then FilExport = 3
Select Case FilExport
Case 1
VuEl = 1
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Case 2
SeparaFisc
ActiveSheet.Protect "NominaugppAP"
VuEl = 0
Case Is > 2
Set Rf2aP = Range(Rff2aP) 'rg copiar los encabezados en el nuevo Ap
Rf2aP.Select
Selection.Copy
Range("L1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, CantColumAp).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
SeparaFisc
ActiveSheet.Protect "NominaugppAP"
VuEl = 0
End Select
For x = 2 To Hojaaa
If VuEl = 1 Then ActiveSheet.Select Else ActiveSheet.Next.Select 'ActiveSheet.Previous.Select
Windows(estLib).Activate
Sheets("AP").Select
ActiveCell.Offset(1, 0).Range("A1").Select
nomHoja = ActiveCell.Value
Sheets(nomHoja).Select
Set Rf5aP = Range(Rff5aP) 'rg para crear filtros
Rf5aP.Select
Selection.Copy
Windows(nuevLib).Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Windows(estLib).Activate
Sheets("AP").Protect ClaHTws
Set Rf7aP = Range(Rff7aP) 'rg para copiar codConceptosAP
Rf7aP.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows(nuevLib).Activate
Range("K1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Range("A2").EntireRow.Delete
Set Rf1aP = Range(Rff1aP) 'rg para borrar WWW
Rf1aP.Select
Selection.Replace What:="www", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Rf1aP.Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireColumn.Delete
Range("A1").Select
ActiveSheet.Name = Range("A2").Value
If Range("K1").Value > 0 Then FilExport = 1
If Range("K2").Value > 0 Then FilExport = 2
If Range("K3").Value > 0 Then FilExport = 3
Select Case FilExport
Case 1
VuEl = 1
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Case 2
SeparaFisc
ActiveSheet.Protect "NominaugppAP"
VuEl = 0
Case Is > 2
Set Rf2aP = Range(Rff2aP) 'rg copiar los encabezados en el nuevo Ap
Rf2aP.Select
Selection.Copy
Range("L1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, CantColumAp).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
SeparaFisc
ActiveSheet.Protect "NominaugppAP"
VuEl = 0
End Select
Next x
ActiveWorkbook.Worksheets(1).Select
Range("A1").Select
Workbooks(nuevLib).Save
MsgBox "Se exporto satisfactoriamente el archivo ", vbInformation + vbOKOnly, MSG
End If
End If
End Sub
Sub SeparaFisc()
Dim MartiK As String
MartiK = Range("A1").Value
Range("A1").FormulaR1C1 = "=COUNTA(R[1]C:R[1048575]C)"
Range("A1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
InserFilaOtras = Range("A1").Value
Range("A1").Value = MartiK
Select Case TipoHT
Case "FISCALIZACION"
Rows("1:1").Select
Range("BV1").Activate
Selection.Find(What:="82", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Case "LIQUIDACION"
Rows("1:1").Select
Range("BV1").Activate
Selection.Find(What:="113", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
End Select
ActiveCell.Offset(1, 1).Range("A1").Select
Selection.EntireColumn.Insert
Selection.EntireColumn.Insert
ActiveCell.Offset(-1, -1).Range("A1").Select
ActiveCell.Resize(InserFilaOtras + 1, 1).Select
Selection.Replace What:="ok", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.Offset(-1, 0).Range("A1").Select
ActiveCell.Formula = "=CELL(""direccion"",RC)"
ActiveCell.Resize(2, 1).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Replace What:="$", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.Offset(-1, 0).Range("A1").Select
Dim LaCel As String
LaCel = ActiveCell.Value
ActiveCell.Resize(InserFilaOtras + 1, 1).Select
Selection.TextToColumns Destination:=Range(LaCel), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, OtherChar _
:=";", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
TrailingMinusNumbers:=True
Select Case TipoHT
Case "FISCALIZACION"
ActiveCell.Offset(0, 2).Range("A1").Select
ActiveCell.Value = 98
ActiveCell.Offset(0, -1).Range("A1").Select
ActiveCell.Value = 97
ActiveCell.Offset(0, -1).Range("A1").Select
ActiveCell.Value = 82
Case "LIQUIDACION"
ActiveCell.Offset(0, 2).Range("A1").Select
ActiveCell.Value = 126
ActiveCell.Offset(0, -1).Range("A1").Select
ActiveCell.Value = 125
ActiveCell.Offset(0, -1).Range("A1").Select
ActiveCell.Value = 113
End Select
ActiveCell.Resize(InserFilaOtras + 1, 3).Select
Selection.Replace What:="ok", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
Sub verNombreHojas() ' ok
Sheets("AP").Select
Application.ScreenUpdating = False
Sheets("AP").Unprotect ClaHTws
Range("A1:M20").Clear
Range("N5").FormulaR1C1 = _
"=IF(OR(R[-2]C="""",R[-2]C[1]="""",R[-2]C[4]="""",R[-2]C[5]="""",R[-2]C[7]="""",R[-2]C[8]="""",R[-2]C[2]="""",R[-2]C[3]=""""),1,0)"
If Range("N5").Value = 1 Then
MsgBox "Debe completar la información poder continuar", vbExclamation + vbOKOnly, MSG
Range("N5").Value = ""
Else
Dim i As Integer, oH As Integer
Dim h As Variant
Range("T3").FormulaR1C1 = _
"=""'""&RIGHT(""000000000000000""&RC[-6],15)&RIGHT(""00""&DAY(RC[-2]),2)&RIGHT(""00""&MONTH(RC[-2]),2)&YEAR(RC[-2])&RIGHT(""0000""&RC[-1],4)&RC[2]"
Nomlib = Range("T3").Value
Cells(1, 2).Value = ActiveWorkbook.Sheets.Count
i = 1
oH = 0
For Each h In ActiveWorkbook.Sheets
If Mid(ActiveWorkbook.Sheets(i).Name, 1, 2) = "HT" Then
Cells(i, 1) = h.Name
i = i + 1
oH = oH + 1
End If
Next h
Cells(1, 2).Value = oH
Range("C1").Value = Nomlib
Range("N5").Value = ""
Range("T3").Value = Nomlib
Range("A1").Select
End If
Range("A1:B20").Select
Selection.Locked = False
Selection.FormulaHidden = False
Range("B1").Select
Sheets("AP").Protect ClaHTws
End Sub
Sub ValidaConten()
Sheets("AP").Select
Range("A1").Select
nomHoja = ActiveCell.Value
Sheets(nomHoja).Select
ActiveSheet.Unprotect ClaHTws
TipoHT = Range("H2").Value
Range("J1").Select
Range("J1").FormulaR1C1 = "=SUM(RC[1]:RC[36])"
Range("K1").Select
Range("K1").FormulaR1C1 = "=IF(AND(COUNTA(R[8]C:R[999999]C)>0,R[7]C=""""),1,0)"
Range("K1").Copy
Range("K1").Select
ActiveCell.Resize(1, CantValCon).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("K1").Select
ActiveCell.Resize(1, CantValCon).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ValContHoja = Range("J1").Value
If ActiveSheet.FilterMode = True Then
ValContHoja = 2
Range("J1").Select
ActiveCell.Resize(1, CantValCon + 1).Select
Selection.ClearContents
Range("K8").Select
MsgBox "Primero debe quitar la selección de los filtros", vbInformation + vbOKOnly, MSG
Else
If ValContHoja >= 1 Then
Range("J1").ClearContents
Range("K1").Select
ActiveCell.Resize(1, CantValCon).Select
Selection.Find(What:="1", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.ClearContents
ActiveCell.Offset(7, 0).Range("A1").Select
MsgBox "Debe Ingresar y/o seleccionar el titulo para las columnas con valores", vbCritical + vbOKOnly, MSG
Else
Range("J1").Select
ActiveCell.Resize(1, CantValCon + 1).Select
Selection.ClearContents
RecacularassAPPPP
End If
End If
ActiveSheet.Protect Password:=ClaHTws, DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True
Do While ValContHoja = 0
Sheets("AP").Select
ActiveCell.Offset(1, 0).Range("A1").Select
nomHoja = ActiveCell.Value
If nomHoja = "" Then Exit Do
Sheets(nomHoja).Select
ActiveSheet.Unprotect ClaHTws
Range("J1").Select
Range("J1").FormulaR1C1 = "=SUM(RC[1]:RC[36])"
Range("K1").Select
Range("K1").FormulaR1C1 = "=IF(AND(COUNTA(R[8]C:R[999999]C)>0,R[7]C=""""),1,0)"
Range("K1").Copy
Range("K1").Select
ActiveCell.Resize(1, CantValCon).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("K1").Select
ActiveCell.Resize(1, CantValCon).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ValContHoja = Range("J1").Value
If ActiveSheet.FilterMode = True Then
ValContHoja = 2
Range("J1").Select
ActiveCell.Resize(1, CantValCon + 1).Select
Selection.ClearContents
Range("K8").Select
MsgBox "Primero debe quitar la selección de los filtros", vbInformation + vbOKOnly, MSG
Else
If ValContHoja >= 1 Then
Range("J1").ClearContents
Range("K1").Select
ActiveCell.Resize(1, CantValCon).Select
Selection.Find(What:="1", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.ClearContents
ActiveCell.Offset(7, 0).Range("A1").Select
MsgBox "Debe seleccionar el titulo para las columnas con valores", vbCritical + vbOKOnly, MSG
Else
Range("J1").Select
ActiveCell.Resize(1, CantValCon + 1).Select
Selection.ClearContents
RecacularassAPPPP
End If
End If
ActiveSheet.Protect Password:=ClaHTws, DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True
Loop
End Sub
No me comentaste sobre esto:
Dime cuáles columnas son las que se deben incluir, es decir, dime la letra de la columna.
Esto no lo entiendo, "No deben exportarse espacios en blanco" me lo puedes explicar con ejemplos.
Hola,
El tema es así:
Un rango de filas de (Z4:AD4) contienen datos, se requiere que esa información se pegue en una columna llamada concepto (Convertir esa fila de rango en columna), como es una plantilla tanto en los rangos hacia abajo (Z5:AD5, Z6:AD6,....) hay datos también, estos deben pegarse también a la columna año debajo del primer rango.
Hay un campo en donde esta el año de la plantilla (A5), la idea es que a continuación de todos los datos columna concepto, se pegue el año (Es decir, al frente de cada dato de esa columna debe ir el año).
Esta hoja de Excel tiene varias Hojas con la misma información, lo único que cambia es el año, por en de en la columna concepto y año deben ir todos los datos de los rangos descritos arriba de todas las hojas.
Cuando te indico que no se deben exportar datos en blanco me refiero por ejemplo a que en la posición Z4 no hay nada, al exportar a la nueva hoja debe omitir ese espacio y continuar con el A4.
Este tema es el mismo tema que te solicite en las preguntas anteriores, lo que cambia es que debe hacer parte de una macro ya realizada.
Saludos y mil gracias.
Corrijo la parte donde dice "Continuar con el A4... ", me refiero al AB4.
Saludos
Envíame tu archivo con la macro y me explicas con un ejemplo cómo debería quedar la información.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Angelito junino” y el título de esta pregunta.
Avísame en esta pregunta cuando me lo hayas enviado.
‘
S a l u d o s . D a n t e A m o r
Te acabo de enviar el correo. Te recomiendo mucha discreción.
Mil gracias.
No te preocupes, lo reviso y si tengo dudas te aviso.
¡Gracias!
Como lo ves... Complicado?
Bendiciones
H o l a:
Si cambias la pregunta a privado no podré ayudarte.
Hola,
Ya la hice pública nuevamente.
Saludos,
H o l a:
Este código va en la macro: CrearAPlanoCrearAPlano
'Crear hoja conceptos
'Por. Dante Amor
Dim l2, h2, h, u
Set l2 = Workbooks(nuevLib)
l2.Sheets.Add after:=l2.Sheets(l2.Sheets.Count)
l2.Sheets(l2.Sheets.Count).Name = "Conceptos"
Set h2 = l2.Sheets("Conceptos")
For Each h In ThisWorkbook.Sheets
If Left(h.Name, 2) = "HT" Then
h.Range("U8:AX8").Copy
u = Range("A" & Rows.Count).End(xlUp).Row + 1
h2.Range("B" & u).PasteSpecial Paste:=xlValues, Transpose:=True
h2.Range("A" & u & ":A" & u + 29) = Right(h.Name, 4)
End If
Next
'Fin.Por.Dante AmorTienes que ponerlo antes de de esta línea:
ActiveWorkbook.Worksheets(1).Select
S a l ud o s
¡Gracias!
Gracias,
La macro funciona correctamente
Quisiera que me ayudaras con otro detalle: No deben aparecer datos en blanco al frente de los años, estos aparecen porque estas tomando todo el rango, pero hay que considerar que si esos campos del rango están vacíos no se deben exportar, sólo los que contienen Datos.
Saludos y mil gracias
Este es el código actualizado:
'Crear hoja conceptos
'Por. Dante Amor
Dim l2, h2, h, u, c
Set l2 = Workbooks(nuevLib)
l2.Sheets.Add after:=l2.Sheets(l2.Sheets.Count)
l2.Sheets(l2.Sheets.Count).Name = "Conceptos"
Set h2 = l2.Sheets("Conceptos")
h2.[A1] = "AÑO"
h2.[B1] = "CONCEPTO"
For Each h In ThisWorkbook.Sheets
If Left(h.Name, 2) = "HT" Then
For c = Columns("U").Column To Columns("AX").Column
If h.Cells(8, c) <> "" Then
u = Range("A" & Rows.Count).End(xlUp).Row + 1
h2.Range("A" & u) = Right(h.Name, 4)
h2.Range("B" & u) = h.Cells(8, c)
End If
Next
End If
Next
'Fin. Por. Dante Amor
¡Gracias! Dios te bendiga
Hola Sr. Amor,
Necesito otra cosita más si es posible que me ayudes.
Aparte del rango que te indique (U8:AX8), existe otro (BP8:DL8).
Como quedaría la macro donde la idea es recorrer estos dos rangos por cada Hoja y poner en la columna Conceptos primero el rango (U8:AX) y abajo EL (BP8:DL8)
Mil gracias.
H o l a:
Con gusto te sigo apoyando, crea una nueva pregunta por cada petición.