数据组合输出

转角处的沉思

如图，根据关键字段先按列分别从左至右于对应列下方含有数据的行内容组合，然后在表2将所有结果合并一列输出，效果见表2.

小凡、、、

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.31
   
2.     With Sheets("Sheet1")
   
3.         r = .Cells.SpecialCells(xlCellTypeLastCell).Row
   
4.         arr = .[b1].Resize(r, 8)
   
5.         ReDim brr(1 To 10000, 1 To 1)
   
6.         For j = 1 To UBound(arr, 2)
   
7.             For i = 3 To UBound(arr)
   
8.                 If arr(i, j) <> Empty Then
   
9.                     m = m + 1
   
10.                     brr(m, 1) = CStr(arr(1, j)) & ":" & CStr(arr(i, j))
    
11.                 End If
    
12.             Next
    
13.         Next
    
14.     End With
    
15.     With Sheets("Sheet2")
    
16.         .UsedRange = ""
    
17.         .[a1].Resize(m, 1) = brr
    
18.     End With
    
19.     MsgBox "OK！"
    
20. End Sub
    
21. 
    

复制代码

quqiyuan

参与一下，供参考。。。

小凡、、、

转角处的沉思

小凡、、、 发表于 2024-7-31 15:00

公式效果也不错，感谢帮助。

quqiyuan

代码如下。。。
Sub test()
    arr = Sheet1.Range("b1", Cells(1, Columns.Count).End(1))
    brr = Sheet1.Range("b3:b" & Sheet1.UsedRange.Rows.Count).Resize(, UBound(arr, 2))
    ReDim crr(1 To 100000, 1 To 1)
    For j = 1 To UBound(arr, 2)
        For i = 1 To UBound(brr)
            If brr(i, j) <> Empty Then
                n = n + 1
                crr(n, 1) = arr(1, j) & ":" & brr(i, j)
            End If
        Next
    Next
    Columns("l:l").ClearContents
    [l3].Resize(n) = crr
    Beep
End Sub

转角处的沉思

ykcbf1100 发表于 2024-7-31 15:07
附件供参考。。。

效果很好，感谢帮助。

liuyu5863016

插楼

1. Sub numdark()
   
2. ' 2024/7/31
   
3. 
   
4.     Dim arr1, arr2, result_arr
   
5.     Dim i%, j%, k%
   
6.     Dim ws As Worksheet
   
7.    
   
8.     Set ws = Worksheets("Sheet1")
   
9.     arr1 = ws.[B1:I1]
   
10.     arr2 = ws.[B3:I26]
    
11.    
    
12.     ReDim result_arr(1 To 8 * 24)
    
13.    
    
14.     For i = 1 To 8
    
15.         For j = 1 To 24
    
16.             If arr2(j, i) = "" Then Exit For
    
17.             k = k + 1
    
18.             result_arr(k) = arr1(1, i) & ":" & arr2(j, i)
    
19.         Next j
    
20.     Next i
    
21.    
    
22.     ' 设置文本格式
    
23.     With Worksheets("Sheet2")
    
24.         .[b:b].NumberFormat = "@"
    
25.         .[b1].Resize(k) = Application.Transpose(result_arr)
    
26.     End With
    
27.    
    
28. End Sub
    

复制代码