如何用函数将二维表转换成一维表

一粒粒

求助各位老师，sheet1为原表，sheet2为最终形成的效果，保证每个站均能显示所有车次，我还是基础太差了没整出来（VBA正在尝试学习）

一粒粒

麻烦老师，我自己操作了下了后发现，原表中如果有空白行的话就会显示错误，我修改了下代码还是不行，再者我在原表中和最终形成的结果多加了一列上下行（两张SHEET页中绿色部分），还需要麻烦老师帮忙解答下：
1、在VBA下多添加一列上下行
2、当车次增加或减少时，车站增加或减少时，均不影响代码生成
3、最终形成的效果按照模板应该是到达时间在前，发车时间在后

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    arr = Sheets(1).[a1].CurrentRegion
    Sheets(2).Select
    Sheets(2).UsedRange.Offset(1).ClearContents
    Application.ScreenUpdating = False
    For i = 2 To UBound(arr, 2)
        For j = 5 To 10
            If Len(arr(j, i)) > 0 Then
                dd(arr(3, i) & "#@$" & arr(j, 1)) = 1
                d(arr(3, i) & "#@$" & arr(j, 1) & "#@$" & arr(4, i)) = arr(j, i)
            End If
        Next j
    Next i
    [b2].Resize(dd.Count) = WorksheetFunction.Transpose(dd.keys)
   
    For i = 2 To UBound(arr, 2)
        For j = 14 To 19
            If Len(arr(j, i)) > 0 Then
                dd(arr(12, i) & "#@$" & arr(j, 1)) = 1
                d(arr(12, i) & "#@$" & arr(j, 1) & "#@$" & arr(13, i)) = arr(j, i)
            End If
        Next j
    Next i
    Cells(Rows.Count, 2).End(3).Offset(1).Resize(dd.Count) = WorksheetFunction.Transpose(dd.keys)
    brr = [a1].CurrentRegion
    For j = 2 To UBound(brr)
        brr(j, 1) = arr(1, 1)
        If d.exists(brr(j, 2) & "#@$" & brr(1, 4)) Then
            brr(j, 4) = d(brr(j, 2) & "#@$" & brr(1, 4))
        End If
        If d.exists(brr(j, 2) & "#@$" & brr(1, 5)) Then
            brr(j, 5) = d(brr(j, 2) & "#@$" & brr(1, 5))
        End If
        crr = Split(brr(j, 2), "#@$")
        brr(j, 2) = crr(0)
        brr(j, 3) = crr(1)
    Next j
    [a1].CurrentRegion = brr
    Application.ScreenUpdating = True
End Sub

liulang0808

跟楼主模拟数据有出入，供参考

一粒粒

有没有老师能用函数先解决这问题，VBA正在用老师的方法研究中

笨鸟飞不高

时刻表10月15日实行（函数）.zip (23.87 KB, 下载次数: 5)

2020-11-25 15:09 上传

点击文件名下载附件

vba的练习一个！！

一粒粒

liulang0808 发表于 2020-11-25 12:51
跟楼主模拟数据有出入，供参考

多谢帮助，很有用

笨鸟飞不高

时刻表10月15日实行（函数）.zip (23.31 KB, 下载次数: 14)

2020-11-25 15:20 上传

点击文件名下载附件

刚才没仔细看要求，发现有点出入！！

笨鸟飞不高

Sub AwTest()
    Dim i&, j%, k%, x&, r&, c%, sl$, kStr$, arr, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    With Sheet1
        sl = "怀柔-密云线"
        arr = .Range("A3:M" & .Cells(Rows.Count, 1).End(3).Row)
        ReDim brr(1 To 5000, 1 To 5)
        For i = 3 To UBound(arr) Step 9
            For j = 2 To UBound(arr, 2)
                For k = 0 To 5
                    kStr = arr(i - 2, j) & "|" & arr(i + k, 1)
                    x = d(kStr)
                    If x = 0 Then
                        r = r + 1: d(kStr) = r: brr(r, 1) = sl
                        brr(r, 2) = arr(i - 2, j): brr(r, 3) = arr(i + k, 1): x = r
                    End If
                    If arr(i - 1, j) = "到达时间（HH24MI）" Then c = 4 Else c = 5
                    brr(x, c) = arr(i + k, j)
                Next
            Next
        Next
    End With
    Sheet2.[j4].Resize(r, 2).NumberFormat = "h:mm"
    Sheet2.[g4].Resize(r, 5) = brr
End Sub

cjc209

笨鸟飞不高 发表于 2020-11-25 15:21
刚才没仔细看要求，发现有点出入！！

写的高         

wang-way