[已解决]请问如何通过VBA实现帖子当中所要求的排序？

shenlong2006 · 发表于 2014-3-4 13:56

文件中有两个excel文件“表1、表2”（如下图）：

表格1中的内容格式如下：

表格2中的内容格式如下：

我想让表格2按照“地址编号”调整顺序，使得表格2中的“地址编号”先后顺序与他们在表格1中的相同，请问如何通过VBA实现呢？

对比排序.rar (12.95 KB, 下载次数: 10)

dsmch · 发表于 2014-3-4 13:56

………………

独奏 · 发表于 2014-3-4 15:55

本帖最后由独奏于 2014-3-4 19:12 编辑

新手练手，请先保存好副本
忘记了说一下，我把合并的单元格都拆分了并填上相应的序号和名称

Sub text()
Dim br, arr, brr, crr(), wb, r, c, x, y
Set wb = Workbooks.Open(ThisWorkbook.Path & "\表1.xls")
With wb
arr = .Sheets("sheet1").Range("a1").CurrentRegion
br = Workbooks("表2.xls").Sheets("sheet1").Range("a1:j1")
brr = Workbooks("表2.xls").Sheets("sheet1").Range("a1").CurrentRegion
For r = 2 To UBound(arr)
For x = 2 To UBound(brr)
If brr(x, 2) = arr(r, 2) Then
n = n + 1
ReDim Preserve crr(1 To 10, 1 To n)
For y = 1 To UBound(brr, 2)
crr(y, n) = brr(x, y)
Next
End If
Next
Next
End With
Workbooks("表2.xls").Sheets("sheet2").Range("a1").Resize(, 10) = br
Workbooks("表2.xls").Sheets("sheet2").Range("a2").Resize(n, 10) = Application.Transpose(crr)
set arr=nothing
set brr=nothing
erase crr
End Sub

复制代码

独奏 · 发表于 2014-3-4 19:48

这个不拆分单元格的也可以试试，请保存好副本

Sub test()
Dim arr()
Set wb = Workbooks.Open(ThisWorkbook.Path & "\表1.xls")
With wb
brr = .Sheets("sheet1").Range("a1").CurrentRegion
End With
ThisWorkbook.Activate
With Workbooks("表2.xls").Sheets(1)
For y = 2 To UBound(brr)
For r = 2 To 89
If brr(y, 2) = .Cells(r, 2) Then
If Cells(r, 2).MergeCells Then
For x = r To r + .Cells(r, 2).MergeArea.Rows.Count - 1
n = n + 1
ReDim Preserve arr(1 To 10, 1 To n)
For i = 1 To 10
arr(i, n) = .Cells(x, i)
Next
Next
r = x
End If
End If
Next
Next
End With
Workbooks("表2.xls").Sheets(2).Range("a1").Resize(n, 10) = Application.Transpose(arr)
End Sub

复制代码

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