能否实行一键归类

青青的河边草

在表中，能否点击按钮，A列从最后一个数起，依次导入105个数据到表的上框A表中；B列从最后一个数起，依次导入105个数据到表的上框B表中；C列、D列、E列、F列、G列同理。

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, a, b
  For j = 1 To 7
    arr = Cells(1, j).Resize(Cells(Rows.Count, j).End(xlUp).Row)
    ReDim brr(1 To 15, 1 To 7)
    a = 0: b = 1
    For i = UBound(arr, 1) To UBound(arr, 1) - UBound(brr, 1) * UBound(brr, 2) + 1 Step -1
      a = a + 1
      brr(a, b) = arr(i, 1)
      If a = UBound(brr, 1) Then a = 0: b = b + 1
    Next
    Cells(2, (j - 1) * 8 + 9).Resize(UBound(brr, 1), UBound(brr, 2)) = brr
  Next
End Sub

liulang0808

1. Private Sub CommandButton1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     c = 9
   
4.     For j = 1 To 7
   
5.         r = Cells(Rows.Count, j).End(3).Row
   
6.         m = 0
   
7.         For i = r - 14 To 1 Step -15
   
8.             If m < 7 Then
   
9.                 Cells(2, c + m).Resize(15).Value = Cells(i, j).Resize(15).Value
   
10.                 m = m + 1
    
11.             Else
    
12.                 Exit For
    
13.             End If
    
14.         Next i
    
15.         c = c + 8
    
16.     Next j
    
17.     Application.ScreenUpdating = True
    
18. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim sh As Worksheet, lngRows As Long, lngCol As Long
   
5.     Dim arrData As Variant, arrResult As Variant, rgResult As Range
   
6.    
   
7.     Set sh = Sheets("Sheet1")
   
8.     Set rgResult = sh.Range("I2") '起始填充单元
   
9.     lngRows = sh.Range("A" & Rows.Count).End(xlUp).Row
   
10.    
    
11.     If lngRows < 122 Then Exit Sub
    
12.    
    
13.     arrData = sh.Range("A18:G" & lngRows)
    
14.    
    
15.     For lngCol = LBound(arrData, 2) To UBound(arrData, 2)
    
16.         arrResult = GetValByCol(arrData, lngCol)
    
17.         rgResult.Resize(15, 7) = arrResult
    
18.         Set rgResult = rgResult.Offset(0, 8)
    
19.     Next
    
20.    
    
21.     Set rgResult = Nothing
    
22.     Set sh = Nothing
    
23.     MsgBox "OK"
    
24. End Sub
    
25. 
    
26. Function GetValByCol(arrSource As Variant, lngColID As Long) As Variant
    
27.     Dim arrTemp As Variant, arrResult As Variant
    
28.     Dim lngRow As Long, lngEnd As Long
    
29.     Dim lngID_R As Long, lngID_C As Long
    
30.    
    
31.     ReDim arrResult(1 To 15, 1 To 7)
    
32.    
    
33.     arrTemp = Application.WorksheetFunction.Index(arrSource, 0, lngColID)
    
34.     If UBound(arrTemp) < 105 Then
    
35.         GetValByCol = arrResult
    
36.         Exit Function
    
37.     End If
    
38.    
    
39.     lngEnd = UBound(arrTemp) - 104
    
40.     lngID_C = 1: lngID_R = 15
    
41.     For lngRow = UBound(arrTemp) To lngEnd Step -1
    
42.         arrResult(lngID_R, lngID_C) = arrTemp(lngRow, 1)
    
43.         lngID_R = lngID_R - 1
    
44.         If lngID_R = 0 Then
    
45.             lngID_R = 15
    
46.             lngID_C = lngID_C + 1
    
47.         End If
    
48.     Next
    
49.     GetValByCol = arrResult
    
50. End Function

复制代码