Forum Discussion

Celinaexcel's avatar
Celinaexcel
Copper Contributor
Jun 21, 2023

Please help: Excel VBA move completed projects to next worksheet (big worksheet)

Hello all,   I am new to VBA coding and I have a big spreadsheet.   I would like to cut and move an entire row to the worksheet named "Historic Sales" once I give the Value "completed" in Column ...
excel
Macros and VBA
office 365
peiyezhu's avatar
peiyezhu
Bronze Contributor
Jun 22, 2023
however it doesn't seem to be working.
VBA Coding ?

If with VBA,I don't know how to do more research.

Maybe filter by keywords instead of moving will be more easier to process.

Celinaexcel's avatar
Celinaexcel
Copper Contributor
Jun 23, 2023
I've been trying this Code, but when I then write Done into the Area by Z nothing is moving.
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Overview").UsedRange.Rows.Count
J = Worksheets("Completed Projects").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Completed Projects").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Overview").Range("Z4:Z" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Done" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Completed Projects").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Done" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
  • peiyezhu's avatar
    peiyezhu
    Bronze Contributor
    Jun 23, 2023

    Celinaexcel 

    split to 2 sheets according to done or not?

    https://blog.csdn.net/hhhhh_51/article/details/122414404

    https://club.excelhome.net/forum.php?mod=viewthread&tid=1655820&fromguid=hot&extra=&mobile=

     

    Sub 工作表按列拆分为工作表()
    '当前工作表（worksheet）按固定某列的值拆分为多个工作表，保存在当前工作簿（workbook）
    Dim arr, dict As Object
    Set dict = CreateObject("scripting.dictionary")
'--------------------参数填写：num_col，数字，A列为1向右递增；title_row，数字，第1行为1向下递增
    num_col = 4  '关键值列，按该列的值进行拆分，相同的保存在同一ws
    title_row = 1  '表头行，每个拆分后的sheet都保留
    Set ws = Application.ActiveSheet
    arr = ActiveSheet.UsedRange  '所有数据行读取为数组，也可arr = [a1].CurrentRegion
    
    For i = title_row + 1 To UBound(arr):  '遍历关键值列，写入字典，key为关键值，item为对应的行
        If Not dict.Exists(arr(i, num_col)) Then  '新键-值
            Set dict(arr(i, num_col)) = Rows(i)
        Else  '已有键-值，更新
            Set dict(arr(i, num_col)) = Union(dict(arr(i, num_col)), Rows(i))
        End If
    Next
    
    k = dict.Keys:v = dict.Items
    For i = 0 To dict.count - 1:  '遍历字典，创建、写入ws
        'Worksheets.Add(after:=Sheets(Sheets.count)).Name = "拆分表" & i + 1  '最后添加新sheet，序号命名
        Worksheets.Add(after:=Sheets(Sheets.count)).Name = "拆分表_" & k(i)  '最后添加新sheet，keys命名
        With ActiveSheet
            ws.Rows(1).Copy
            .[a1].PasteSpecial Paste:=xlPasteColumnWidths  '复制列宽
            ws.Rows(1 & ":" & title_row).Copy .[a1]  '复制表头
            v(i).Copy .Range("A" & title_row + 1)  '复制数据
        End With
        'Exit For  '强制退出for循环，单次测试使用
    Next
End Sub