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.
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".
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.
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)
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)
- i want to copy a specific sheet to another file with vba
- vba - extract information on a separate sheet with excel
- conditional branch of sheet search&creation from vba cell value
- vba - how to change sheet name to cell value
- vba sheet 1 a7, c7, sheet 2 a2 "2020" 03 "01" numerical value is added and displayed in the cell as "20
- vba - i want to divide the sheet by the same data
- i want to extract only the one that has a specific value in column a from multiple cells with vba
- how to refer the value of another sheet with vba form
- vba - i want to select a sheet and copy the contents to another sheet
- vba how to specify font size that does not move on the sheet you want to execute
- vba - speed up when moving old data to another sheet
- unable to get number of columns and number of columns per vba sheet
- vba: cannot copy and paste to another sheet in the same workbook
- [vba] extract data of another sheet multiple times
- vba - i want to use worksheetfunctionvlookup to get data from another sheet, but i can't refer to it
- vba:i want to paste a specific range of values into the body of an outlook email
- copying a specific sheet in a workbook containing a macro in excel vba causes the macro to be transferred to a specific sheet
- want to import excelvba sheet into list box
- i want to put a code to determine whether the checkbox on the sheet is checked in excelvba, but i get an error
- python - you may need to restart the kernel to use updated packages error
- php - coincheck api authentication doesn't work
- php - i would like to introduce the coincheck api so that i can make payments with bitcoin on my ec site
- [php] i want to get account information using coincheck api
- the emulator process for avd pixel_2_api_29 was killed occurred when the android studio emulator was started, so i would like to
- python 3x - typeerror: 'method' object is not subscriptable
- i want to call a child component method from a parent in vuejs
- dart - flutter: the instance member'stars' can't be accessed in an initializer error
- xcode - pod install [!] no `podfile 'found in the project directory