楼主
liuguansky |
Q：如何把多行多列的数据转化成多行两列的流水格式？
A：
用如下代码可以实现：
一、数组：
- Sub justtest()
- Dim arr, i&, j&, k&, arrt()
- With Sheet1
- arr = .UsedRange.Value
- For i = 1 To UBound(arr, 1)
- For j = 2 To UBound(arr, 2)
- If arr(i, j) <> "" Then
- k = k + 1
- ReDim Preserve arrt(1 To 2, 1 To k)
- arrt(1, k) = arr(i, 1)
- arrt(2, k) = arr(i, j)
- End If
- Next j, i
- End With
- On Error Resume Next
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Sheets("ShiftResult").Delete
- Sheets.Add
- With ActiveSheet
- .Name = "ShiftResult"
- .Cells(1, 1).Resize(k, 2) = Application.Transpose(arrt)
- End With
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
二、数组+字典：
- Sub justtest1()
- Dim arr, i&, j&, k&, arrs, arrt(), dic
- Set dic = CreateObject("scripting.dictionary")
- With Sheet1
- arr = .UsedRange.Value
- For i = 1 To UBound(arr, 1)
- For j = 2 To UBound(arr, 2)
- If arr(i, j) <> "" Then
- dic(arr(i, 1) & vbTab & arr(i, j)) = ""
- End If
- Next j, i
- End With
- arrs = dic.keys
- ReDim arrrt(dic.Count - 1, 1)
- For i = 0 To dic.Count - 1
- For j = 0 To 1
- arrrt(i, j) = Split(arrs(i), vbTab)(j)
- Next j, i
- On Error Resume Next
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Sheets("ShiftResult").Delete
- Sheets.Add
- With ActiveSheet
- .Name = "ShiftResult"
- .Cells(1, 1).Resize(i, 2) = arrrt
- End With
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
具体示例文件如下：
|