Como puedo pasar una fila de item a otra hoja
Para dante amor
En base a esta macro
Sub Macro2()
'
Dim strTitulo As String
Dim Continuar As String
Dim hoja As String
Dim TransRowRng As Range
Dim NewRow As Integer
'
strTitulo = "Transferencia Entre Bodegas"
hoja = Sheets("hoja1").Range("D1")
If hoja = "" Then
MsgBox "Debes indicar un nombre de hoja"
Exit Sub
End If
For Each h In Sheets
If UCase(h.Name) = UCase(hoja) Then
existe = True
Exit For
End If
Next
If existe = False Then
MsgBox "No existe la hoja: " & hoja
Exit Sub
End If
'
Continuar = MsgBox("Realizar Transferencia?", vbYesNo + vbExclamation, strTitulo)
If Continuar = vbNo Then Exit Sub
'
Set TransRowRng = ThisWorkbook.Worksheets(hoja).Cells(1, 1).CurrentRegion
NewRow = TransRowRng.Rows.Count + 1
With ThisWorkbook.Worksheets(hoja)
.Cells(NewRow, 2).Value = ThisWorkbook.Sheets(1).Range("F23")
.Cells(NewRow, 4).Value = Date
. Cells(NewRow, 5).Value = ThisWorkbook. Sheets(1). Range("L3")
.Cells(NewRow, 7).Value = ThisWorkbook.Sheets(1).Range("E23")
.Cells(NewRow, 9).Value = ThisWorkbook.Sheets(1).Range("N16")
.Cells(NewRow, 10).Value = ThisWorkbook.Sheets(1).Range("L18")
End With
'
MsgBox "Transferencia Exitosa.", vbInformation, strTitulo
End Subtengo esta guía de salida y quiero trasladar los items ingresados a una base de datos de transferencia
Aqui estan los items ingresados y lo que deseo es que se pase todos con los mismos datos
Esta es la base de datos donde debe de poner todos los items en los campos de "descripcion" y "salida" y los campos de "fecha","guia","unidad","chofer" se copien igual x la cantidad de items ingresados
Ya que la macro actual solo pasa la primera fila.
1 Respuesta
Respuesta de Dante Amor
2
Te anexo la macro actualizada
Sub Macro2()
'
Dim strTitulo As String
Dim Continuar As String
Dim hoja As String
Dim TransRowRng As Range
Dim NewRow As Integer
'
strTitulo = "Transferencia Entre Bodegas"
hoja = Sheets("hoja1").Range("D1")
If hoja = "" Then
MsgBox "Debes indicar un nombre de hoja"
Exit Sub
End If
For Each h In Sheets
If UCase(h.Name) = UCase(hoja) Then
existe = True
Exit For
End If
Next
If existe = False Then
MsgBox "No existe la hoja: " & hoja
Exit Sub
End If
'
Continuar = MsgBox("Realizar Transferencia?", vbYesNo + vbExclamation, strTitulo)
If Continuar = vbNo Then Exit Sub
Set h1 = ThisWorkbook.Sheets(1)
'
Set TransRowRng = ThisWorkbook.Worksheets(hoja).Cells(1, 1).CurrentRegion
NewRow = TransRowRng.Rows.Count + 1
fila = 23
With ThisWorkbook.Worksheets(hoja)
Do While h1.Cells(fila, "F") <> ""
.Cells(NewRow, 2).Value = h1.Range("F" & fila)
.Cells(NewRow, 4).Value = Date
.Cells(NewRow, 5).Value = h1.Range("L3")
.Cells(NewRow, 7).Value = h1.Range("E" & fila)
.Cells(NewRow, 9).Value = h1.Range("N16")
.Cells(NewRow, 10).Value = h1.Range("L18")
fila = fila + 1
NewRow = NewRow + 1
Loop
End With
'
MsgBox "Transferencia Exitosa.", vbInformation, strTitulo
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
