Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

5144 / 76735

←次へ　｜　前へ→


	【77204】Re:配列の有効数を求める(空白がある)

β - 15/6/16(火) 10:23 -


	引用なし

	パスワード

▼まりさん：

仮に　↑　のような要件であれば、以下の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

0 hits

▼

【77197】配列の有効数を求める(空白がある) まり 15/6/15(月) 17:18