|
本帖最后由 lvxia 于 2015-11-12 19:37 编辑
B10:lvxia- Option Explicit
- Sub 不规范数据转清单()
- Dim arr1, arr2, brr, crr, drr
- Dim irows As Long, i As Long, j As Long, k As Byte, Icolumns1 As Byte, Icolumns2 As Byte
- irows = Range("a65536").End(xlUp).Row
- arr1 = Range("a1:a" & irows)
- '求brr列数
- For i = 1 To UBound(arr1)
- If arr1(i, 1) <> "" Then
- Icolumns1 = Icolumns1 + 1
- Else
- Exit For
- End If
- Next
- '求arr2行数
- For i = 1 To UBound(arr1)
- If arr1(i, 1) <> "" Then Icolumns2 = Icolumns2 + 1
- Next
- '非空数据存入arr2
- ReDim arr2(1 To Icolumns2, 1 To 1)
- For i = 1 To UBound(arr1)
- If arr1(i, 1) <> "" Then j = j + 1: arr2(j, 1) = arr1(i, 1)
- Next
- 'arr2分列,存入brr
- ReDim brr(1 To Icolumns2, 1 To 2)
- For i = 1 To UBound(arr2)
- drr = Split(arr2(i, 1), ":")
- brr(i, 1) = drr(0)
- brr(i, 2) = drr(1)
- Next
- '转置后存入crr
- ReDim crr(1 To Icolumns2 / Icolumns1 + 1, 1 To Icolumns1)
- For i = 1 To Icolumns1
- crr(1, i) = brr(i, 1)
- Next
- j = 1
- For i = 2 To Icolumns2 / Icolumns1 + 1
- For k = 1 To Icolumns1
- If brr(j, 1) = crr(1, k) Then crr(i, k) = brr(j, 2): j = j + 1
- Next
- Next
- '结果写入指定区域
- [c1].Resize(UBound(crr), UBound(crr, 2)) = crr
- End Sub
复制代码- Option Explicit
- Sub 日期()
- Dim arr1, arr2, arr3, irows%, ICount%, i%, j%, k%, m%
- irows = Worksheets("表2").Range("C4").End(xlDown).Row
- arr1 = Worksheets("表2").Range("C4:C" & irows)
- k = 1
- ReDim arr2(1 To UBound(arr1), 1 To 1)
- For i = 1 To UBound(arr1)
- For j = 1 To UBound(arr1)
- If Year(arr2(j, 1)) & Month(arr2(j, 1)) = Year(arr1(i, 1)) & Month(arr1(i, 1)) Then ICount = ICount + 1
- Next
- If ICount = 0 Then
- arr2(k, 1) = arr1(i, 1)
- k = k + 1
- Else
- ICount = 0
- End If
- Next
- '求出arr2非空元素的个数
- For i = 1 To UBound(arr2)
- If arr2(i, 1) <> "" Then ICount = ICount + 1
- Next
- k = 1
- m = 1
- '结果数据存入arr3
- ReDim arr3(1 To UBound(arr1) + ICount, 1 To 1)
- For i = 1 To ICount
- arr3(k, 1) = Year(arr2(i, 1)) & "年" & Month(arr2(i, 1)) & "月"
- For j = m To UBound(arr1)
- If Year(arr1(j, 1)) & Month(arr1(j, 1)) = Year(arr2(i, 1)) & Month(arr2(i, 1)) Then
- k = k + 1
- arr3(k, 1) = arr1(j, 1)
- Else
- k = k
- Exit For
- End If
- Next
- k = k + 1
- m = j
- Next
- '结果写入表一指定区域
- Worksheets("表1").Range("M2").Resize(UBound(arr3)) = arr3
- End Sub
复制代码 |
评分
-
查看全部评分
|