重新计算导出的表格，序号重新排序

nongminku125 · 发表于 2024-1-10 12:01

表格上端和下端有两部分排序，下面的排序和上面的排序是一直的，现在宏运行后，新的表格，排序怎么编辑为上端表格排序为所在行减去2，下端表格和上面的对应，谢谢啊，谢谢各位大佬！！！！！
形成新的排序如下面的显示

grf1973 · 发表于 2024-1-10 14:26

把问题描述清楚。排序结果示例。

nongminku125 · 发表于 2024-1-10 14:35

各位大佬，上面的表显示原表的排序，我宏运行之后，会有新的表格，新的表格，里面的序号还是之前的表格排序，我想运行宏之后的表格序号也能够重新排序，谢谢。

ykcbf1100 · 发表于 2024-1-10 19:24

讲实话，我也没看明白。
建议楼主摸拟一个结果出来，不然，不好理解。如果无法理解，那肯定写不了代码。

nongminku125 · 发表于 2024-1-10 21:33

目前宏运算的显示效果
希望达到的效果，

jinxuanmr · 发表于 2024-1-10 22:15

一个excel工作表上有上下两个部分的数据，要求运行vb后两个部分都按照A列的序号排序是吗？

jinxuanmr · 发表于 2024-1-11 01:14

Sub Test()
Dim rng As Range
Dim Colm As Integer
Dim keye As String
Dim Ar, Br As Variant
If Worksheets.Count = 1 Then: Worksheets.Add after:=Sheets(Sheets.Count)
With Sheet1
keye = .Cells(1, 1).Value
Ar = .Range("a1").CurrentRegion.Value
Br = .Range("a" & UBound(Ar)).End(xlDown).CurrentRegion.Value
With Worksheets(Sheets.Count)
.Range(.Cells(1, 1), .Cells(UBound(Ar), UBound(Ar, 2))) = Ar
.Cells(1, 1).Value = "排序"
Set rng = .Range(.Cells(1, 1), .Cells(UBound(Ar), UBound(Ar, 2)))
rng.Sort key1:="排序", order1:=xlAscending, Header:=xlYes
.Cells(1, 1).Value = keye
keye = Br(1, 1)
Br(1, 1) = "排序"
.Cells(UBound(Ar) + 2, 1).Resize(UBound(Br), UBound(Br, 2)) = Br
Set rng = .Cells(UBound(Ar) + 2, 1).CurrentRegion
rng.Sort key1:="排序", order1:=xlAscending, Header:=xlYes
.Cells(UBound(Ar) + 2, 1) = keye
End With
End With
Erase Ar
Erase Br
End Sub

复制代码

jinxuanmr · 发表于 2024-1-11 01:37

是你想要的吗？

Sub Test()
Dim rng As Range
Dim keye As String
Dim Ar, Br As Variant
If Worksheets.Count = 1 Then: Worksheets.Add after:=Sheets(Sheets.Count)
With Sheet1
keye = .Cells(1, 1).Value
Ar = .Range("a1").CurrentRegion.Value
Br = .Range("a" & UBound(Ar)).End(xlDown).CurrentRegion.Value
With Worksheets(Sheets.Count)
.Range(.Cells(1, 1), .Cells(UBound(Ar), UBound(Ar, 2))) = Ar
.Cells(1, 1).Value = "排序"
Set rng = .Range(.Cells(1, 1), .Cells(UBound(Ar), UBound(Ar, 2)))
rng.Sort key1:="排序", order1:=xlAscending, Header:=xlYes
.Cells(1, 1).Value = keye
keye = Br(1, 1)
Br(1, 1) = "排序"
.Cells(UBound(Ar) + 2, 1).Resize(UBound(Br), UBound(Br, 2)) = Br
Set rng = .Cells(UBound(Ar) + 2, 1).CurrentRegion
rng.Sort key1:="排序", order1:=xlAscending, Header:=xlYes
.Cells(UBound(Ar) + 2, 1) = keye
End With
End With
Erase Ar
Erase Br
End Sub

复制代码

jinxuanmr · 发表于 2024-1-11 02:20

代码发不出去，这个作用是将sheet1的两部分数据，复制到新sheet，然后分别排序。不知道是不是你想要的。

nongminku125 · 发表于 2024-1-11 09:56

各位大佬：
  这是我原来的宏代码，请问新的代码如何添加进去，一起运行，
Sub ykcbf() '//2023.4.12
Dim arr, brr
p = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
arr = Sheet15.UsedRange
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 2 To UBound(arr)
      If InStr(arr(i, 4), "删除") = 0 And InStr(arr(i, 15), "删除") = 0 And InStr(arr(i, 24), "删除") = 0 Then
         m = m + 1
         For j = 1 To UBound(arr, 2)
            brr(m, j) = arr(i, j)
         Next
      End If
Next
Set wb = Workbooks.Add
Set sht = wb.Sheets(1)
With sht
      .Columns("a:BW").NumberFormatLocal = "@"
      .[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
End With
mFile = p & "文件另存.xlsx"
wb.SaveAs Filename:=mFile, FileFormat:=51
wb.Close True
Application.ScreenUpdating = True
MsgBox "另存完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
End Sub

Sub 凭证生成()

End Sub
导出的表格，相关的序号都能自动排序，谢谢！！！！！！

		自动登录	找回密码
密码			免费注册

[求助] 重新计算导出的表格，序号重新排序