Macro para copiar información de un documento a otro pero no permite escoger otra hoja diferente a la actual.
Tengo esta macro la cual permite abrir un documento y seleccionar la cantidad de columnas que quiero copiar y pegar en un documento totalmente nuevo. El problema que tengo es que si el documento destino tiene más de una hoja solo permite tomar la hoja actual pero quiero que al abrirlo me permita seleccionar la hoja que yo desee y una vez seleccionada ahí si proceda con el resto de la macro (pedir cantidad de columnas, seleccionarlas, copiarlas, pegarlas en el nuevo documento, reemplazar los valores y terminar la macro)
Sub move_data()
Dim data_wb As Workbook
Dim target_wb As Workbook
Dim file_name As Variant
Dim header_range(100) As Range
Dim last_row As Long
Dim col_number As Long
Dim col_letter As String
Dim counter As Long
Dim quantity As Long
'select workbook
file_name = Application.GetOpenFilename(Title:="Choose a target Workbook")
If file_name <> False Then
'create a new target workbook
Set target_wb = Application.Workbooks.Add
'open Workbook with the data
Set data_wb = Application.Workbooks.Open(file_name)
'get quantity to create loop
quantity = _
InputBox("How many columns do you want to copy?")
'loop
For counter = 1 To quantity
'select header range
Set header_range(counter) = _
Application.InputBox("Select the HEADER of the " & counter & "º column you want to copy", Type:=8)
'get last row and col letter
col_number = header_range(counter).Column
last_row = Cells(Rows.Count, col_number).End(xlUp).Row
col_letter = Split(Cells(1, col_number).Address(True, False), "$")(0)
'copy from data_wb
Range(header_range(counter), Range(col_letter & last_row)).Copy
'pastein target_wb
target_wb.Sheets("Sheet1").Cells(1, counter).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Next counter
Application.CutCopyMode = False
End If
target_wb.Sheets("Sheet1").Cells.Replace What:="NBCU Id", Replacement:="NBCU ID"
target_wb.Sheets("Sheet1").Cells.Replace What:="Channel", Replacement:="ChannelName"
target_wb.Sheets("Sheet1").Cells.Replace What:="Content Title", Replacement:="Show"
target_wb.Sheets("Sheet1").Cells.Replace What:="Season#", Replacement:="Season"
target_wb.Sheets("Sheet1").Cells.Replace What:="Episode#", Replacement:="Eps"
target_wb.Sheets("Sheet1").Cells.Replace What:="License Start Date", Replacement:="VOD Start"
target_wb.Sheets("Sheet1").Cells.Replace What:="License End Date", Replacement:="VOD End"
target_wb.Sheets("Sheet1").Cells.Replace What:="E!", Replacement:="E"
target_wb.Sheets("Sheet1").Cells.Replace What:="Studio", Replacement:="STUDIO"
target_wb.Sheets("Sheet1").Cells.Replace What:="SyFy", Replacement:="SYFY"
target_wb.Sheets("Sheet1").Cells.Replace What:="Telemundo Internacional", Replacement:="TELEMUNDO INTERNACIONAL"
target_wb.Sheets("Sheet1").Cells.Replace What:="Universal TV", Replacement:="UTV"
target_wb.Sheets("Sheet1").Cells.Replace What:="DreamWorks", Replacement:="DREAMWORKS"
target_wb.Sheets("Sheet1").Cells.Replace What:="Universal Cinema", Replacement:="Cinema"
target_wb.Sheets("Sheet1").Cells.Replace What:="Universal Comedy", Replacement:="Comedy"
target_wb.Sheets("Sheet1").Cells.Replace What:="Universal Crime", Replacement:="Crime"
target_wb.Sheets("Sheet1").Cells.Replace What:="Universal Premiere", Replacement:="Premiere"
target_wb.Sheets("Sheet1").Cells.Replace What:="Universal Reality", Replacement:="Reality"
target_wb.Sheets("Sheet1").Range("A1:H1").Name = "Print_Area"
lastCol = target_wb.Sheets("Sheet1").Range("A2").End(xlToRight).Column
lastRow = target_wb.Sheets("Sheet1").Cells(target_wb.Sheets("Sheet1").Rows.Count, lastCol).End(xlUp).Row
target_wb.Sheets("Sheet1").Range("A2", target_wb.Sheets("Sheet1").Cells(lastRow, lastCol)).Name = "vodoffer"
target_wb.Sheets("Sheet1").Name = "Detail"
target_wb.Sheets.Add
target_wb.Sheets("Sheet2").Name = "Product"
target_wb.Sheets("Product").Range("A1").Value = InputBox("Write the type of product: Basic or Premium")
End Sub
Adicionalmente, me gustaría que una vez se acabe de correr la macro me salga la ventana de guardar este nuevo documento que crea de ceros y el nombre del archivo sea el que está en la celda A1 del documento y hoja destino y se pueda guardar ahí con el aceptar de la venta de guardar como.
Mil gracias de antemano.
3 Respuestas
Revisa lo siguiente:
Sal u dos
Dante Amor
Te dejo un par de instrucciones que quedaron entre '*****.
Allí te permite ingresar el nombre de la hoja de trabajo. Si queda vacío se asume que será la hoja activa, la de la apertura. Sino seleccionará previamente la que solicitas y luego seguirá con el número de columnas.
'open Workbook with the data
Set data_wb = Application.Workbooks.Open(file_name)
'**************************************
Dim hojax As String
hojax = InputBox("Si necesitas activar una hoja diferente, ingresa su nombre.")
If hojax <> "" Then Sheets(hojax).Activate
'get quantity to create loop
quantity = InputBox("How many columns do you want to copy?")
If quantity = "" Then Exit Sub 'evita error si se cancela el InputBox
'**************************************
'loop Al final agregué una línea para controlar si se cancela o se deja vacía la variable 'quantity'.
Te aclaro un poco más la modificación que tendrías que hacer, por si no quedó claro lo de los asteriscos ;)
En tu macro, todas esas líneas de color amarillo debes quitarlas y colocar las que te agrego a continuación. En el nuevo InputBox coloca el texto en inglés. El resto corrió bien.
Dim hojax As String
hojax = InputBox("Si necesitas activar una hoja diferente, ingresa su nombre.")
If hojax <> "" Then Sheets(hojax).Activate
'get quantity to create loop
quantity = InputBox("How many columns do you want to copy?")
If quantity = "" Then Exit Sub 'evita error si se cancela el InputBoxNo olvides que cada siempre hay que evaluar si un inputbox queda vacío o no.
Hola Elsa, muchas gracias por tu ayuda, estoy modificando la macro según tus indicaciones.
Quería preguntarte si puedes ayudarme en lo que solicité a lo último en mi mensaje.
"Adicionalmente, me gustaría que una vez se acabe de correr la macro me salga la ventana de guardar este nuevo documento que crea de ceros y el nombre del archivo sea el que está en la celda A1 del documento y hoja destino y se pueda guardar ahí con el aceptar de la venta de guardar como.
Mil gracias de antemano."
Elsa, al agregar la línea que me indicas para evaluar si el inputbox está vacío la macro crea un bug y no corre.
Adicionalmente, al querer correr la macro dentro el mismo archivo destino me obliga a si o si buscar el archivo en el explorador de windows, ¿es posible eliminar esta sentencia y que lo tome por default? Yo lo intenté de mil formas pero no me fue posible.
Es porque tu variable fue declarada como Long. Pasa a valor el resultado del InputBox, ajustando estas 2 líneas:
quantity = Val(InputBox("How many columns do you want to copy?"))
If quantity = 0 Then Exit SubCon respecto al adicional, fijate en la macro que te dejó Vera, creo que esa parte la tiene desarrollada. Sino quizás Dante quiera aportar también algo de código en esta consulta ;)
Sdos!
Aquí tienes la macro modificada que te permite seleccionar la hoja de destino antes de copiar los datos.
Sub move_data()
Dim data_wb As Workbook
Dim target_wb As Workbook
Dim file_name As Variant
Dim header_range(100) As Range
Dim last_row As Long
Dim col_number As Long
Dim col_letter As String
Dim counter As Long
Dim quantity As Long
file_name = Application.GetOpenFilename(Title:="Choose a target Workbook")
If file_name <> False Then
Set target_wb = Application.Workbooks.Add
Set data_wb = Application.Workbooks.Open(file_name)
Dim target_sheet As Worksheet
Set target_sheet = Application.InputBox("Select the target sheet in the new workbook", Type:=8).Worksheet
quantity = InputBox("How many columns do you want to copy?")
For counter = 1 To quantity
Set header_range(counter) = Application.InputBox("Select the HEADER of the " & counter & "º column you want to copy", Type:=8)
.Replace What:="Telemundo Internacional", Replacement:="TELEMUNDO INTERNACIONAL"
.Replace What:="Universal TV", Replacement:="UTV"
.Replace What:="DreamWorks", Replacement:="DREAMWORKS"
.Replace What:="Universal Cinema", Replacement:="Cinema"
.Replace What:="Universal Comedy", Replacement:="Comedy"
.Replace What:="Universal Crime", Replacement:="Crime"
.Replace What:="Universal Premiere", Replacement:="Premiere"
.Replace What:="Universal Reality", Replacement:="Reality"
End With
target_sheet.Range("A1:H1").Name = "Print_Area"
Dim lastCol As Long
Dim lastRow As Long
lastCol = target_sheet.Range("A2").End(xlToRight).Column
lastRow = target_sheet.Cells(target_sheet.Rows.Count, lastCol).End(xlUp).Row
target_sheet.Range("A2", target_sheet.Cells(lastRow, lastCol)).Name = "vodoffer"
target_sheet.Name = "Detail"
target_wb.Sheets.Add
target_wb.Sheets("Sheet2").Name = "Product"
target_wb.Sheets("Product").Range("A1").Value = InputBox("Write the type of product: Basic or Premium")
Dim save_path As Variant
save_path = Application.GetSaveAsFilename(InitialFileName:=target_sheet.Range("A1").Value, FileFilter:="Excel Files (*.xlsx), *.xlsx")
If save_path <> False Then
target_wb.SaveAs save_path
End If
data_wb.Close SaveChanges:=False
target_wb.Close SaveChanges:=False
End Sub
col_number = header_range(counter).Column
last_row = target_sheet.Cells(target_sheet.Rows.Count, col_number).End(xlUp).Row
col_letter = Split(target_sheet.Cells(1, col_number).Address(True, False), "$")(0)
data_wb.Worksheets(1).Range(header_range(counter), data_wb.Worksheets(1).Range(col_letter & last_row)).Copy
target_sheet.Cells(1, counter).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next counter
Application.CutCopyMode = False
End If
With target_sheet.Cells
.Replace What:="NBCU Id", Replacement:="NBCU ID"
.Replace What:="Channel", Replacement:="ChannelName"
.Replace What:="Content Title", Replacement:="Show"
.Replace What:="Season#", Replacement:="Season"
.Replace What:="Episode#", Replacement:="Eps"
.Replace What:="License Start Date", Replacement:="VOD Start"
.Replace What:="License End Date", Replacement:="VOD End"
.Replace What:="E!", Replacement:="E"
.Replace What:="Studio", Replacement:="STUDIO"
.Replace What:="SyFy", Replacement:="SYFY"
.Replace What:="Telemundo Internacional", Replacement:="TELEMUNDO INTERNACIONAL"
.Replace What:="Universal TV", Replacement:="UTV"
.Replace What:="DreamWorks", Replacement:="DREAMWORKS"
.Replace What:="Universal Cinema", Replacement:="Cinema"
.Replace What:="Universal Comedy", Replacement:="Comedy"
.Replace What:="Universal Crime", Replacement:="Crime"
.Replace What:="Universal Premiere", Replacement:="Premiere"
.Replace What:="Universal Reality", Replacement:="Reality"
End With
target_sheet.Range("A1:H1").Name = "Print_Area"
Dim lastCol As Long
Dim lastRow As Long
lastCol = target_sheet.Range("A2").End(xlToRight).Column
lastRow = target_sheet.Cells(target_sheet.Rows.Count, lastCol).End(xlUp).Row
target_sheet.Range("A2", target_sheet.Cells(lastRow, lastCol)).Name = "vodoffer"
target_sheet.Name = "Detail"
target_wb.Sheets.Add
target_wb.Sheets("Sheet2").Name = "Product"
target_wb.Sheets("Product").Range("A1").Value = InputBox("Write the type of product: Basic or Premium")
Dim save_path As Variant
save_path = Application.GetSaveAsFilename(InitialFileName:=target_sheet.Range("A1").Value, FileFilter:="Excel Files (*.xlsx), *.xlsx")
If save_path <> False Then
target_wb.SaveAs save_path
End If
data_wb.Close SaveChanges:=False
target_wb.Close SaveChanges:=False
End Sub