VBA 按照当前周数升序排列

Irisforever

跪求大神帮忙解决周数排序问题。

描述： 1. 第一行为从1到52的星期周数。
          2. 周数下方有若干条对应数据


目的： 1. 将当前日期周数作为第一个排列的周数。如本周是本年度第34周，则数字34在第一格
          2. 后面的周数按升序排列，第52周后循环到第1周
          3. 下方的数据一起变动，需对应准确


先谢过各位了！

一把小刀闯天下

'如果周是无序的要先作排序，你这是有序的，，，

Option Explicit

Sub test()
  Dim arr, pos, n, i, j, k, brr
  arr = [a1].CurrentRegion
  brr = arr: n = 1
  For j = 2 To UBound(arr, 2)
    If arr(1, j) = 34 Then
      pos = j
      For k = pos To UBound(arr, 2)
        n = n + 1
        For i = 1 To UBound(arr, 1): brr(i, n) = arr(i, k): Next
      Next
      Exit For
    End If
  Next
  For j = 2 To pos - 1
    n = n + 1
    For i = 1 To UBound(arr, 1): brr(i, n) = arr(i, j): Next
  Next
  [a28].Resize(UBound(brr, 1), UBound(brr, 2)) = brr '输出位置自己修改
End Sub

chxw68

1. Sub test()
   
2.   Dim r%, i%, c%, j%
   
3.   Dim arr, brr
   
4.   With Worksheets("sheet1")
   
5.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
6.     r = .UsedRange.Find(what:="*", lookat:=xlWhole, LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
7.     arr = .Range("b1").Resize(r, c - 1)
   
8.     zs = Application.WeekNum(Date)
   
9.     ReDim brr(1 To 2, 1 To UBound(arr, 2))
   
10.     For j = 1 To UBound(arr, 2)
    
11.       brr(1, j) = j
    
12.       If arr(1, j) >= zs Then
    
13.         brr(2, j) = arr(1, j)
    
14.       Else
    
15.         brr(2, j) = arr(1, j) + 52
    
16.       End If
    
17.     Next
    
18.     For i = 1 To UBound(brr, 2) - 1
    
19.       p = i
    
20.       For j = i + 1 To UBound(brr, 2)
    
21.         If brr(2, p) > brr(2, j) Then
    
22.           p = j
    
23.         End If
    
24.       Next
    
25.       If p <> i Then
    
26.         For k = 1 To UBound(brr)
    
27.           temp = brr(k, i)
    
28.           brr(k, i) = brr(k, p)
    
29.           brr(k, p) = temp
    
30.         Next
    
31.       End If
    
32.     Next
    
33.     ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
    
34.     For k = 1 To UBound(brr, 2)
    
35.       For i = 1 To UBound(arr)
    
36.         crr(i, k) = arr(i, brr(1, k))
    
37.       Next
    
38.     Next
    
39.   End With
    
40.   With Worksheets("sheet2")
    
41.     .Cells.Clear
    
42.     .Range("a1") = "Week"
    
43.     .Range("b1").Resize(UBound(crr), UBound(crr, 2)) = crr
    
44.   End With
    
45. End Sub
    

复制代码

chxw68

练练练手。

Irisforever

chxw68 发表于 2018-8-23 08:13

真.大神！  请收下我的膝盖！