|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
自己看代码:
- Sub Test()
- Dim arr As Variant, lngR As Long, lngC As Long
- Dim objDicKeys As Object, objDicA As Object, objDicB As Object, arrKeys As Variant
- Dim strKey As String, strRow_1() As String, strRow_2() As String, strValue() As String
- Dim arrResult As Variant
- Dim lngRowCount As Long, lngRows As Long
- Dim lngRow_Start_ID As Long
-
- arr = Sheet1.Range("A1").CurrentRegion
-
- Set objDicKeys = CreateObject("Scripting.Dictionary")
- Set objDicA = CreateObject("Scripting.Dictionary")
- Set objDicB = CreateObject("Scripting.Dictionary")
-
- ReDim arrResult(1 To 7, 1 To 1)
-
- For lngR = 3 To UBound(arr)
- If arr(lngR, 1) <> "" Then
- objDicKeys(arr(lngR, 1)) = ""
- objDicA(arr(lngR, 1)) = objDicA(arr(lngR, 1)) & "|" & arr(lngR, 2) & "@" & arr(lngR, 3)
- End If
-
- If arr(lngR, 5) <> "" Then
- objDicKeys(arr(lngR, 5)) = ""
- objDicB(arr(lngR, 5)) = objDicB(arr(lngR, 5)) & "|" & arr(lngR, 6) & "@" & arr(lngR, 7)
- End If
- Next
-
- arrKeys = objDicKeys.keys
- lngRow_Start_ID = 1
- lngRowCount = 0
- For lngR = LBound(arrKeys) To UBound(arrKeys)
- strKey = arrKeys(lngR)
- strRow_1 = Split(objDicA(strKey), "|")
- strRow_2 = Split(objDicB(strKey), "|")
-
- lngRows = IIf(UBound(strRow_1) > UBound(strRow_2), UBound(strRow_1), UBound(strRow_2))
-
- lngRowCount = lngRowCount + lngRows
-
- ReDim Preserve arrResult(1 To 7, 1 To lngRowCount)
-
- For lngC = 1 To UBound(strRow_1)
- strValue = Split(strRow_1(lngC), "@")
- arrResult(1, lngRow_Start_ID + lngC - 1) = strKey
- arrResult(2, lngRow_Start_ID + lngC - 1) = strValue(0)
- arrResult(3, lngRow_Start_ID + lngC - 1) = strValue(1)
- Next
- For lngC = 1 To UBound(strRow_2)
- strValue = Split(strRow_2(lngC), "@")
- arrResult(5, lngRow_Start_ID + lngC - 1) = strKey
- arrResult(6, lngRow_Start_ID + lngC - 1) = strValue(0)
- arrResult(7, lngRow_Start_ID + lngC - 1) = strValue(1)
- Next
-
- lngRow_Start_ID = lngRowCount + 1
- Next
-
- Sheet1.Range("R3").Resize(lngRowCount, 7) = Application.WorksheetFunction.Transpose(arrResult)
- End Sub
复制代码 |
|