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
Celinaexcel's avatar
Celinaexcel
Copper Contributor
Jun 22, 2023

peiyezhu  I looked into it, and also followed the Links in that thread, however it doesn't seem to be working. I am not sure I understand what Information I have to switch to make it work for my case.

  • peiyezhu's avatar
    peiyezhu
    Bronze Contributor
    Jun 23, 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

Resources