VBA 一维转二维

On_fire

VBA 一维转二维

*

Sheet1 源数据,

AQ2~BC列是要处理的数据, 每行是一组数据

( 注: 不参加处理的数据暂时删掉 )

*

代码的逻辑如下,

1.      AQ列的数字 = 对应横向列, 左到右 ( AB到AO列 )

2.      AR列的数字 = 对应直向的行, 上到下 ( 4~17行 )

3.      在AB4格, 顺序先列后行, 输出每行对应的AS列 ( AU列, BA列 ), 共3列数据

4.      注: 保留字符色

*

部分模拟结果在Sheet1(2)

*

有点难度,

恳请大神, 老师出手帮忙…谢谢!!!

红军2023

1. Sub Convert1Dto2D()
   
2.     Dim i As Long, j As Long
   
3.     Dim rng1D As Range, rng2D As Range
   
4.     Dim ws As Worksheet
   
5.    
   
6.     Set ws = ThisWorkbook.Sheets("Sheet1")
   
7.     Set rng1D = ws.Range("AQ2:BC17")
   
8.    
   
9.     For i = 2 To rng1D.Rows.Count
   
10.         Dim aq As Long
    
11.         aq = rng1D(i, 1).Value
    
12.         
    
13.         For j = 1 To 17
    
14.             Dim cellValue As Variant
    
15.             cellValue = ws.Cells(i, j).Value
    
16.             
    
17.             If cellValue <> "" Then
    
18.                 Dim arr() As Variant
    
19.                 arr = Split(ws.Cells(i - 3, j + 2).Value, ",")
    
20.             End If
    
21.         Next j
    
22.     Next i
    
23. End Sub

复制代码

红军2023

Sub Convert1Dto2D()
    Dim i As Long, j As Long
    Dim rng1D As Range, rng2D As Range
    Dim ws As Worksheet
   
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set rng1D = ws.Range("AQ2:BC17")
   
    For i = 2 To rng1D.Rows.Count
        Dim aq As Long
        aq = rng1D(i, 1).Value
        
        For j = 1 To 17
            Dim cellValue As Variant
            cellValue = ws.Cells(i, j).Value
            
            If cellValue <> "" Then
                Dim arr() As Variant
                arr = Split(ws.Cells(i - 3, j + 2).Value, ",")
            End If
        Next j
    Next i
End Sub

红军2023

Sub Convert1Dto2D()     Dim i As Long, j As Long     Dim rng1D As Range, rng2D As Range     Dim ws As Worksheet          Set ws = ThisWorkbook.Sheets("Sheet1")     Set rng1D = ws.Range("AQ2:BC17")          For i = 2 To rng1D.Rows.Count         Dim aq As Long         aq = rng1D(i, 1).Value                  For j = 1 To 17             Dim cellValue As Variant             cellValue = ws.Cells(i, j).Value                          If cellValue <> "" Then                 Dim arr() As Variant                 arr = Split(ws.Cells(i - 3, j + 2).Value, ",")             End If         Next j     Next i End Sub

yynrzwh

Forms.rar (74.31 KB, 下载次数: 11)

2024-1-14 23:34 上传

点击文件名下载附件

On_fire

yynrzwh 发表于 2024-1-14 23:34

早上好, 谢谢老师…

chxw68

这是楼主最好理解的一个问题。

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, i&, j&, iColor&, Rng As Range
   
    [AB4].CurrentRegion.Clear
    Set Rng = [AB4:AO17]
    With Range("AQ2", Cells(Rows.Count, "BC").End(xlUp))
        ar = .Value
        For i = 1 To UBound(ar)
            iColor = .Cells(i, 1).Font.Color
            With Rng.Cells(ar(i, 2), ar(i, 1))
                .Value = ar(i, 3) & "(" & ar(i, 5) & "," & ar(i, 11) & ")"
                .Font.Color = iColor
            End With
        Next i
    End With
    Beep
End Sub

gwjkkkkk

参与一下。。。

On_fire

chxw68 发表于 2024-1-15 11:01
这是楼主最好理解的一个问题。

早上好,
褚老师, 谢谢您, 让您见笑了...