| |
▼まり さん：
仮に ↑ のような要件であれば、以下のCompressArrayは配列を与え、その中の、完全空白列や
完全空白行を取り除き、小さな配列にするコードです。
Testでは、A1:F20 にあるデータを配列に入れ、それを圧縮して、H1 からの領域に落とし込んでいます。
Sub Test() '空白行列の圧縮
Dim v As Variant
v = Range("A1:F20").Value 'テストデータ
v = CompressArray(v, xlByColumns)
v = CompressArray(v, xlByRows)
MsgBox "有効行数:" & UBound(v, 1) & vbLf & "有効桁数:" & UBound(v, 2)
Range("H1:M20").ClearContents
Range("H1").Resize(UBound(v, 1), UBound(v, 2)).Value = v
End Sub
Function CompressArray(vnt As Variant, Optional by As XlSearchOrder = xlByRows) As Variant '空白列の圧縮
'xlByRows 空白行を圧縮
'xlByColumns 空白列を圧縮
Dim t() As Variant
Dim x As Long
Dim y As Long
Dim cnt As Long
Dim pos As Long
Dim v As Variant
v = vnt
If by = xlByRows Then v = WorksheetFunction.Transpose(v)
ReDim t(0 To UBound(v, 2) - 1)
pos = 0
For y = 1 To UBound(v, 2)
cnt = 0
For x = 1 To UBound(v, 1)
If Len(v(x, y)) > 0 Then Exit For
cnt = cnt + 1
Next
If cnt <> UBound(v, 1) Then '空白列
t(pos) = y
pos = pos + 1
End If
Next
If pos = 0 Then
CompressArray = vnt
Else
ReDim Preserve t(0 To pos - 1)
CompressArray = Application.Index(v, Evaluate("row(1:" & UBound(v, 1) & ")"), t)
End If
If by = xlByRows Then CompressArray = WorksheetFunction.Transpose(CompressArray)
End Function
|
|
独覚
- 15/6/18(木) 10:29 -
かの
- 15/6/18(木) 10:03 -
まり
- 15/6/17(水) 18:11 -
レナレナ
- 15/6/17(水) 15:18 -
