Home>

We are creating a calendar.
I want to keep a history of completed schedules, so when I click the button, "Complete" is displayed in the U column of Sheet 1.
I want to create a line that is transcribed (cut out) from the 3rd line of Sheet 2
Sheet 2 is an image in which the completed schedule of Sheet 1 is posted more and more.

[Sheet 1]
I have a calendar that uses rows 8 of column B to row 307 of AM column (B8: AM307).
For rows where the appointment is complete, column U is marked "Complete".

[Sheet 2]
I would like to transfer the row that says "Complete" in the U column of Sheet 1 to the 3rd row of B column of Sheet 2.

I did some research on my own, but with the code below, only half-finished lines are posted.
Please professor.

Private Sub kanryou_Click ()
Dim i, LastRow As Long
LastRow = Cells (Rows.Count, 1) .End (xlUp) .Row
For i = 1 To Last Row
If Cells (i, 21) = "Done" Then
Rows (i) .Cut Sheets ("Completed"). Cells (Rows.Count, 1) .End (xlUp) .Offset (1, 0)
End If
Next i
End Sub

vba
  • Answer # 1

    Here you will. Only a simple check is done here.
    In particular, we do not check each column in detail (confirmation of function expression columns and non-function expression columns).
    Please check the details on your own.

    Private Sub kanryou_Click ()
        Const endRow As Long = 307
        Const startRow As Long = 8
        Dim wrow As Long, LastRow As Long
        Dim from Row As Long
        Dim to Row As Long
        Dim sh1 As Worksheet
        Dim sh2 As Worksheet
        Dim dicT As Object'Remember the completed line number
        Dim ctr As Long'Number of completions
        Set dicT = CreateObject ("Scripting.Dictionary")'Define an associative array
        Set sh1 = Worksheets ("Calendar")
        Set sh2 = Worksheets ("Completed")
        LastRow = sh2.Cells (Rows.Count, "B"). End (xlUp) .Row + 1
        If LastRow<3 Then LastRow = 3
        ctr = 0
        For wrow = startRow To endRow
            If sh1.Cells (wrow, "U") = "Done" Then
                sh1.Range ("B"&wrow&": AM"&wrow) .Copy sh2.Range ("B"&lastRow&": AM"&lastRow)
                sh1.Cells (wrow, "U") = ""
                ctr = ctr + 1
                If ctr = 1 Then
                    toRow = wrow
                    fromRow = wrow
                End If
                dicT (wrow) = True
                LastRow = LastRow + 1
            End If
        Next wrow
        If ctr = 0 Then
            MsgBox ("No Done Line")
            Exit Sub
        End If
        Do While (toRow<endRow)fromRow = get_from_row (dicT, endRow, fromRow + 1)
            If from Row = -1 Then
                Exit Do
            End If
            Call move_line (sh1, toRow, fromRow)
            toRow = toRow + 1
        Loop
        For wrow = endRow --ctr + 1 To endRow
            Call clear_line (sh1, wrow)
        Next
        MsgBox (ctr&"row processing complete")
    End Sub
    Private Function get_from_row (ByVal dicT As Object, ByVal endRow As Long, ByVal fromRow As Long) As Long
        get_from_row = -1
        Do
            If fromRow>endRow Then Exit Function
            If dicT.Exists (fromRow) = False Then
                get_from_row = fromRow
                Exit Function
            End If
            fromRow = fromRow + 1
        Loop
    End Function
    Private Sub move_line (ByVal ws As Worksheet, ByVal toRow As Long, ByVal from Row As Long)
        ws.Range ("B"&toRow) .Value = ws.Range ("B"&fromRow) .Value
        ws.Range ("C"&toRow) .Value = ws.Range ("C"&fromRow) .Value
        ws.Range ("E"&toRow) .Value = ws.Range ("E"&fromRow) .Value
        ws.Range ("G"&toRow&": U"&toRow) .Value = ws.Range ("G"&fromRow&": U"&fromRow) .Value
        ws.Range ("AJ"&toRow) .Value = ws.Range ("AJ"&fromRow) .Value
        ws.Range ("AL"&toRow) .Value = ws.Range ("AL"&fromRow) .Value
    End Sub
    Private Sub clear_line (ByVal ws As Worksheet, ByVal toRow As Long)
        ws.Range ("B"&toRow) .ClearContents
        ws.Range ("C"&toRow) .ClearContents
        ws.Range ("E"&toRow) .ClearContents
        ws.Range ("G"&toRow&": U"&toRow) .ClearContents
        ws.Range ("AJ"&to Row) .ClearContentsws.Range ("AL"&toRow) .ClearContents
    End Sub

  • Answer # 2

    How about this?

    Private Sub kanryou_Click ()
        Dim wrow As Long, LastRow As Long
        Dim sh1 As Worksheet
        Dim sh2 As Worksheet
        Set sh1 = Worksheets ("Sheet1")
        Set sh2 = Worksheets ("Completed")
        LastRow = sh2.Cells (Rows.Count, "B"). End (xlUp) .Row + 1
        If LastRow<3 Then LastRow = 3
        For wrow = 8 To 307
            If sh1.Cells (wrow, 21) = "Done" Then
                sh1.Range ("B"&wrow&": AM"&wrow). Cut sh2.Range ("B"&lastRow&": AM"&lastRow)
                LastRow = LastRow + 1
            End If
        Next wrow
    End Sub

  • Answer # 3

    Extract with an auto filter,
    Once you copy and paste, you don't have to write the loop in VBA.
    However, the table requires a title row.

    If you do it this way, start by recording a macro.
    Also, I feel that the sample is likely to be on the net.

    Also, if you extract with the filter option function,
    There may be even less VBA code.
    Although it will stain the sheet. .. .. ..

    Oh, it's not a copy, it's a move.
    Then it's an auto filter.

  • Answer # 4

    >If possible, I would be happy if I could move up the blank line on Sheet 1.
    Which case is (1) or (2)?
    This is the state before cutting.

    This is just after cutting. Lines 11 and 14 are blank.

    ① Move the blank line up. (This is what you presented)

    ② Move the blank line down. (Confirm that it is not here just in case)