求助：导出新表，定位最后所在行错误

山海风云轩

求助：需要将某工作表导出为新表，读取有内容所在的最后行，用来定位，

方便调整所选区域的格式，表格中有写代码，但是读取最后行出现偏差，
求助老板完善代码，具体需求见附件
运行环境：WPS

longming3

合并单元格排序本身就无法操作，加辅助列来完成吧。比如单元格输入1.1、1.2、1.3、2.1、2.2、2.3、2.4、3.1、3.2之类

mmwwdd

Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
    With Sheets("sheet2")
    r = .Cells(.Rows.Count, 3).End(3).Row
    Set rng = .Range("a3:i" & r)
    End With
Set wb = Workbooks.Add
Set ws = wb.Sheets(2)
With wb.Sheets(1)
    rng.Copy .Range("A2")
    .Rows("1:2").Copy ws.Range("A1")
    r = .Cells(.Rows.Count, 3).End(3).Row
    last = r
    xh = 1
    Do While last > 3
        For i = 3 To last
        If .Cells(i, 1).MergeArea.Cells(1, 1).Address = .Cells(i, 1).Address Then
        k = .Cells(i, 1)
            If k = xh Then
                     If .Cells(i, 1).MergeCells = True Then
                         hs = .Cells(i, 1).MergeArea.Count
                        .Range("A" & i & ":I" & i + hs - 1).Cut Destination:=ws.Range("A" & ws.Cells(ws.Rows.Count, 3).End(3).Row + 1)
                     Else
                        .Range("A" & i & ":I" & i).Cut Destination:=ws.Range("A" & ws.Cells(ws.Rows.Count, 3).End(3).Row + 1)
                     End If
                     With ws
                     
                     End With
            End If
        End If
        Next
      xh = xh + 1
      r = .Cells(.Rows.Count, 3).End(3).Row
      last = r
   Loop
   .Rows("1:2").Copy ws.Range("A1")
End With
End Sub

mmwwdd

给你新写了一个

mmwwdd

山海风云轩

mmwwdd 发表于 2023-5-28 05:21
Sub test()
Dim wb As Workbook
Dim ws As Worksheet

感谢大佬的热心相助！

我自己后面也修改好了，定位是需要调用指定sheet的代码才可以，因为实际工作中是涉及到多个SHEET