求助大神，这个代码怎样写，才能出现我要的效果，数据量大。

jinjiang123

求助大神，这个代码怎样写，才能出现我要的效果，数据量大。压缩包里分层数据1sheet1表是原始数据，最终要的结果在sheet2表。我试着写了分层数据2，简化了一下，只能提出一口井的数据，希望大神能解决分层数据1的问题，数据较多。

longwin

Sub test()
    Set d = CreateObject("scripting.dictionary")
    zr = Sheet1.[a1].End(xlDown).Row
    zc = Sheet1.[a1].End(xlToRight).Column
    arr = Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(zr, zc))
    For i = 3 To zr
        For j = 2 To zc Step 2
            If arr(i, j) <> "" And arr(i, j + 1) <> "" Then
                d(arr(i, 1) & "|" & arr(2, j)) = Array(arr(i, j), arr(i, j + 1))
            End If
        Next
    Next
    ReDim crr(1 To 1 + d.Count, 1 To 4)
    crr(1, 1) = "井号"
    crr(1, 2) = "层系名"
    crr(1, 3) = "MD"
    crr(1, 4) = "TVD"
    m = 1
    For Each Key In d
        m = m + 1
        crr(m, 1) = Split(Key, "|")(0)
        crr(m, 2) = Split(Key, "|")(1)
        crr(m, 3) = d(Key)(0)
        crr(m, 4) = d(Key)(1)
    Next
   
    Sheet2.[O1].Resize(UBound(crr), UBound(crr, 2)) = crr
End Sub

longwin

分层1数据整理见附件。

蓝桥玄霜

分层例子：
以sheet1数据为准。

lkqsmxw

kkkkkkkkkkkkkkkkkkkkkkkkk

jinjiang123

多谢诸位大神的帮助，正是我想要的，多谢！！！

usedrange

参与一下

1. Sub t()
   
2.     Dim dic, t, m%, i%, j%, arr, brr, k, r%
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     With Sheet1
   
5.         m = .[a1].End(4).Row
   
6.         arr = .Range("a1").CurrentRegion
   
7.         ReDim brr(1 To 100000, 1 To 4)
   
8.         For i = 2 To UBound(arr)
   
9.             For j = 2 To UBound(arr, 2)
   
10.                 If arr(i, j) <> "" And j Mod 2 = 0 Then
    
11.                     dic(arr(i, 1) & "|" & arr(1, j) & "|" & arr(i, j)) = arr(i, j + 1)
    
12.                 End If
    
13.             Next j
    
14.         Next i
    
15.         r = 1
    
16.         For Each k In dic.keys
    
17.             t = Split(k, "|")
    
18.             brr(r, 1) = t(0)
    
19.             brr(r, 2) = Split(t(1))(1)
    
20.             brr(r, 3) = t(2)
    
21.             brr(r, 4) = dic(k)
    
22.             r = r + 1
    
23.         Next k
    
24.         Sheet2.[a2].Resize(UBound(brr), 4) = brr
    
25.     End With
    
26. End Sub
    

复制代码