员工表有若干字段，如何按某个字段顺序要求，重新排列这个员工表，求VBA代码？（有...

ylaxsm · 发表于 2025-1-12 20:22

如图所示，有一个员工表，领导感觉字段顺序排列不妥。
现在另外有个《排序依据》表。
然后根据这个先后顺序，把员工表的所有列进行排列成新表。求VBA代码。

飞天篮球猪 · 发表于 2025-1-12 20:50

插件解法...仅供参考

chxw68 · 发表于 2025-1-12 20:59

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("排序依据")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:a" & r)
For i = 2 To UBound(arr)
d(arr(i, 1)) = i - 1
Next
End With
With Worksheets("员工表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(1, c)
ReDim brr(1 To UBound(arr, 2))
For j = 1 To UBound(arr, 2)
If d.exists(arr(1, j)) Then
brr(j) = d(arr(1, j))
Else
brr(j) = 1000
End If
Next
With .Cells(r + 1, 1).Resize(1, UBound(brr))
.NumberFormatLocal = "0"
.Value = brr
End With
With .Sort
.SortFields.Clear
.SetRange Range("A1:P" & r + 1)
.SortFields.Add Key:=.Parent.Cells(r + 1, 1).Resize(1, c), Order:=xlAscending
.Header = xlYes
.MatchCase = False
.Orientation = xlLeftToRight
.Apply
End With
.Rows(r + 1).Delete
End With
End Sub

复制代码

chxw68 · 发表于 2025-1-12 21:00

参与一下。

qzu888 · 发表于 2025-1-12 21:09

chxw68 发表于 2025-1-12 21:00
参与一下。

已解决，谢谢老师

朝露孤烟 · 发表于 2025-1-12 21:35

在“要达到的效果”的A2，输入=CHOOSECOLS(员工表!$A$2:$P$32,MATCH(A1,员工表!$A$1:$P$1,0))，然后右拉公式。

ykcbf1100 · 发表于 2025-1-13 08:04

参与一下，字典

ykcbf1100 · 发表于 2025-1-13 08:06

参与一下。。。

Sub ykcbf() '//2025.1.13
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
arr = Sheets("员工表").UsedRange
zrr = Sheets("排序依据").UsedRange
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For j = 1 To UBound(arr, 2)
s = arr(1, j)
d1(s) = ""
Next
For i = 2 To UBound(zrr)
s = zrr(i, 1)
If d1.exists(s) Then
n = n + 1
d(s) = n
End If
Next
For i = 1 To UBound(arr)
m = m + 1
For j = 1 To UBound(arr, 2)
s = arr(1, j)
If d.exists(s) Then
brr(m, d(s)) = arr(i, j)
End If
Next
Next
With Sheets("需要达到的效果")
.UsedRange.ClearContents
.[a1].Resize(m, UBound(arr, 2)) = brr
End With
Set d = Nothing
MsgBox "OK！"
End Sub

复制代码

3190496160 · 发表于 2025-1-13 09:54

Sub 排序()
Dim ar As Variant, br As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("排序依据")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "排序依据为空！": End
ar = .Range("a1:a" & r)
End With
With Sheets("员工表")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
y = .Cells(1, Columns.Count).End(xlToLeft).Column
If rs < 2 Or y < 2 Then MsgBox "员工表为空！": End
br = .Range(.Cells(1, 1), .Cells(r, y))
End With
For j = 1 To UBound(br, 2)
If br(1, j) <> "" Then
      d(br(1, j)) = ""
End If
Next j
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
      If d.exists(ar(i, 1)) Then
         m = m + 1
         dc(ar(i, 1)) = m
      End If
End If
Next i
Dim cr()
ReDim cr(1 To UBound(br), 1 To UBound(br, 2))
For i = 1 To UBound(br)
If br(i, 1) <> "" Then
      n = n + 1
      For j = 1 To UBound(br, 2)
         lh = dc(br(1, j))
         If lh <> "" Then
            cr(n, lh) = br(i, j)
         End If
      Next j
End If
Next i
With Sheets("需要达到的效果")
.[a1].CurrentRegion = Empty
.[a1].Resize(UBound(cr), UBound(cr, 2)) = cr
End With
MsgBox "ok!"
End Sub

3190496160 · 发表于 2025-1-13 09:54

重排顺序.rar (20.65 KB, 下载次数: 3)

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

[求助] 员工表有若干字段，如何按某个字段顺序要求，重新排列这个员工表，求VBA代码？（有...