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 Sub

tengo 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
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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas