[已解决]谢谢青城老师，如何进行数据提取，分行分列

lhj323323

老师：
上传的附件中有详细的说明，如何分行分列提取数据。 对私国际结算中业收入.rar (97.32 KB, 下载次数: 32)

2012-4-6 19:52 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

青城山苦丁茶

2012-4-6 21:57

做了d至j列，可数字不一样
用了字典，要引用
Sub test()
Dim d1 As New Dictionary, d2 As New Dictionary
Dim ar1(), ar()
With Sheets("sheet1")
   i% = .[a65536].End(xlUp).Row
   ar1 = .Range("a2:j" & i).Value
End With
For i = 3 To UBound(ar1)
   d1("" & ar1(i, 1)) = i
Next
For i = 4 To UBound(ar1, 2)
   d2("" & ar1(1, i)) = i
Next
With Sheets("sheet3")
  i = .[a65536].End(xlUp).Row
  ar = .Range("a9:a" & i).Value
End With
For i = 1 To UBound(ar)
  If InStr(ar(i, 1), ":") < 1 And InStr(ar(i, 1), ".") > 4 Then
    ar(i, 1) = Trim(ar(i, 1))
    artmp = Split(Split(ar(i, 1), " ")(0), ".")
    If d1.Exists(artmp(0)) And d2.Exists(artmp(1)) Then
      Do While InStr(ar(i, 1), "  ")
        ar(i, 1) = Replace(ar(i, 1), "   ", " ")
        ar(i, 1) = Replace(ar(i, 1), "  ", " ")
      Loop
      artmp2 = Split(ar(i, 1), " ")
      ar1(d1(artmp(0)), d2(artmp(1))) = artmp2(UBound(artmp2))
    End If
  End If
Next
Sheets("sheet1").Range("a17").Resize(UBound(ar1), UBound(ar1, 2)) = ar1
End Sub

跳转到最佳答案楼层

青城山苦丁茶

做了d至j列，可数字不一样
用了字典，要引用
Sub test()
Dim d1 As New Dictionary, d2 As New Dictionary
Dim ar1(), ar()
With Sheets("sheet1")
   i% = .[a65536].End(xlUp).Row
   ar1 = .Range("a2:j" & i).Value
End With
For i = 3 To UBound(ar1)
   d1("" & ar1(i, 1)) = i
Next
For i = 4 To UBound(ar1, 2)
   d2("" & ar1(1, i)) = i
Next
With Sheets("sheet3")
  i = .[a65536].End(xlUp).Row
  ar = .Range("a9:a" & i).Value
End With
For i = 1 To UBound(ar)
  If InStr(ar(i, 1), ":") < 1 And InStr(ar(i, 1), ".") > 4 Then
    ar(i, 1) = Trim(ar(i, 1))
    artmp = Split(Split(ar(i, 1), " ")(0), ".")
    If d1.Exists(artmp(0)) And d2.Exists(artmp(1)) Then
      Do While InStr(ar(i, 1), "  ")
        ar(i, 1) = Replace(ar(i, 1), "   ", " ")
        ar(i, 1) = Replace(ar(i, 1), "  ", " ")
      Loop
      artmp2 = Split(ar(i, 1), " ")
      ar1(d1(artmp(0)), d2(artmp(1))) = artmp2(UBound(artmp2))
    End If
  End If
Next
Sheets("sheet1").Range("a17").Resize(UBound(ar1), UBound(ar1, 2)) = ar1
End Sub