Pasar información a otra hoja, si hoja existe entonces a próxima fila vacía
Todo Expertos! Tengo una macro que crea una hoja de acuerdo al valor de la celda A1 y traspasa dicha información a la hoja nueva. Me gustaría que si la hoja ya existe coloque la información en la próxima fila vacía, el rango va de B a D
Private Sub CommandButton1_Click()
Dim sh As Worksheet
Dim max As Long, cont As Long
Dim Nombre As String
Set sh = ActiveSheet
'Crear palntilla de jugador
'Máximo de filas a considerar
max = 1
'Recorrer las filas de la columna A desde 1 hasta Max
For cont = 1 To max
'Colocar el contenido de la celda en la variable Nombre
Nombre = sh.Cells(cont, 1).Value
'Si el Nombre es diferente a vacío, entonces crear la nueva hoja
If Nombre <> "" Then
On Error Resume Next
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Nombre
On Error GoTo 0
Sheets(Nombre).Range("B2").Value = sh.Range("D8").Value
Sheets(Nombre).Range("c2").Value = sh.Range("D9").Value
Sheets(Nombre).Range("D2").Value = sh.Range("D10").Value
End If
Next cont
End Sub
1 Respuesta
Respuesta de Dante Amor
2
Te anexo el código actualizado.
NOTA: Cambia en la macro "Hoja2" por el nombre de tu hoja origen
Private Sub CommandButton1_Click()
Dim sh As Worksheet
Dim max As Long, cont As Long, lr As Long
Dim Nombre As String
'
Set sh = Sheets("Hoja2") '<---Nombre de tu hoja origen
'Crear palntilla de jugador
'Máximo de filas a considerar
max = 1
'
'Recorrer las filas de la columna A desde 1 hasta Max
For cont = 1 To max
'Colocar el contenido de la celda en la variable Nombre
Nombre = sh.Cells(cont, 1).Value
'Si el Nombre es diferente a vacío, entonces crear la nueva hoja
If Nombre <> "" Then
'Verifica si existe la hoja
If Evaluate("ISREF('" & Nombre & "'!A1)") Then
lr = Sheets(Nombre).Range("B" & Rows.Count).End(3).Row + 1
Else
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Nombre
lr = 2
End If
With Sheets(Nombre)
.Range("B" & lr).Value = sh.Range("D8").Value
.Range("C" & lr).Value = sh.Range("D9").Value
.Range("D" & lr).Value = sh.Range("D10").Value
End With
End If
Next cont
End Sub
