Excel VBA質問箱 IV

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

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


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

2077 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

▼

【70129】列が空白ならば削除したい ごん 11/10/17(月) 7:47

【70132】Re:列が空白ならば削除したい UO3 11/10/17(月) 9:40

【70136】Re:列が空白ならば削除したい UO3 11/10/17(月) 10:11

【70141】Re:列が空白ならば削除したい UO3 11/10/17(月) 11:06

【70145】Re:列が空白ならば削除したい ごん 11/10/17(月) 11:42

【70144】Re:列が空白ならば削除したい UO3 11/10/17(月) 11:38

【70146】Re:列が空白ならば削除したい ごん 11/10/17(月) 11:48

【70148】Re:列が空白ならば削除したい UO3 11/10/17(月) 11:57

【70149】Re:列が空白ならば削除したい UO3 11/10/17(月) 12:48

【70151】Re:列が空白ならば削除したい ごん 11/10/17(月) 13:57

【70156】Re:列が空白ならば削除したい UO3 11/10/17(月) 17:40

【70159】Re:列が空白ならば削除したい ごん 11/10/18(火) 9:06

【70166】Re:列が空白ならば削除したい UO3 11/10/18(火) 10:27

【70150】Re:列が空白ならば削除したい kanabun 11/10/17(月) 12:53

【70152】Re:列が空白ならば削除したい ごん 11/10/17(月) 15:59


	【70129】列が空白ならば削除したい

ごん - 11/10/17(月) 7:47 -


	引用なし

	パスワード

例えば、C列～F列を選択しマクロを実施すると、C列からF列の３行目以降が空白で何も書かれていなければ、その列は削除してしまいたい。

C～F列の処理が終わったら、次は、また処理をしたいどこかの連続した列を選択し、同じように処理できるようなマクロをお願いします。


	【70132】Re:列が空白ならば削除したい

UO3 - 11/10/17(月) 9:40 -


	引用なし

	パスワード

▼ごんさん：

おはようございます
データが３行目からということですので、別トピ、アルファベットのソートのシートでしょうかね。
それはさておき、別トピでもちらっと示唆しましたが、どんな秀逸なアルゴリズムでコードをかいても
エクセルの本来の機能を活用した処理にくらべると、効率が格段に劣ります。
別トピでいえば、作業列をつくって通常のソート機能を活用するほうが断然早いわけです。

で、今回のテーマですが、空白セルを判定して削除するのではなく
・最も早いのはフィルター機能の活用。
　ただし、この場合、２行目が各列の項目タイトル行である必要があります。
　また、項目タイトルセルが結合されており、そのデータセルが結合されていない場合で
　かつ、その列も判定列にする場合、結合された、一番左の列の値の判定しかできませんので
　「全て空白」という処理はできません。
・おすすめは上の処理ですが、次善の策としては、「残すものを配列に書き込んで」
　最後に置き換え。

２行目がどうなっているか教えていただけますか？


	【70136】Re:列が空白ならば削除したい

UO3 - 11/10/17(月) 10:11 -


	引用なし

	パスワード

▼ごんさん：

追加で確認です。
列の選択は、C列～F列のように、連続した列選択のみですか？
それとも、Ctrlキーをおしながらの、飛び飛びの列選択もありですか？


	【70141】Re:列が空白ならば削除したい

UO3 - 11/10/17(月) 11:06 -


	引用なし

	パスワード

▼ごんさん：

とりあえず「次善の策」としての「配列方式」です。
列は連続でも飛び飛びでもＯＫです。
また、２行目は見ていませんので仮にタイトル行でなくてもＯＫです。

Sub SampleV()
'配列方式
　　Dim myA As Range
　　Dim lCell As Range
　　Dim z As Long
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim v As Variant
　　Dim w() As Variant
　　Dim vCols As Variant
　　Dim allB As Boolean
　　
　　With ActiveSheet.UsedRange
　　　　Set lCell = .Cells(.Cells.Count)
　　End With
　　vCols = getCols(lCell.Column)
　　v = Range("A3", lCell).Value
　　ReDim w(1 To UBound(v, 1), 1 To UBound(v, 2))
　　For i = 1 To UBound(v, 1)
　　　　allB = True
　　　　For j = 1 To UBound(vCols)
　　　　　　If (Len(v(i, vCols(j)))) > 0 Then
　　　　　　　　allB = False
　　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　　　If Not allB Then
　　　　　　k = k + 1
　　　　　　For j = 1 To UBound(w, 2)
　　　　　　　　w(k, j) = v(i, j)
　　　　　　Next
　　　　End If
　　Next
　　Range("A3").Resize(UBound(w, 1), UBound(w, 2)).Value = w
　　MsgBox "処理が完了しました"
End Sub

Private Function getCols(mCols As Long) As Variant
　　Dim a As Range, b As Range
　　Dim k As Long
　　Dim v() As Variant
　　ReDim v(1 To mCols)
　　For Each a In Selection.Areas
　　　　For Each b In a.Rows(1).Cells
　　　　　　k = k + 1
　　　　　　v(k) = b.Column
　　　　Next
　　Next
　　ReDim Preserve v(1 To k)
　　getCols = v
End Function


	【70144】Re:列が空白ならば削除したい

UO3 - 11/10/17(月) 11:38 -


	引用なし

	パスワード

▼ごんさん：

オートフィルターによる処理案です。
２行目がタイトル行、かつ、２行目が結合されている列は選択できません。
（選択されればエラーメッセージをだして中断します）

Sub SampleA()
'オートフィルター
　　Dim myA As Range
　　Dim myR As Range
　　Dim lCell As Range
　　Dim z As Long
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim v As Variant
　　Dim w() As Variant
　　Dim vCols As Variant
　　Dim allB As Boolean
　　Dim ct As Variant
　　
　　With ActiveSheet.UsedRange
　　　　Set lCell = .Cells(.Cells.Count)
　　End With
　　vCols = checkCols(lCell.Column)
　　If Not IsArray(vCols) Then
　　　　MsgBox "タイトル行が結合されている列は選択できません"
　　　　Exit Sub
　　End If
　　
　　Application.ScreenUpdating = False
　　
　　Set myA = Range("A2", lCell)
　　'オートフィルター設定が残っていれば、いったんリセット
　　If ActiveSheet.AutoFilterMode Then _
　　　　　　ActiveSheet.AutoFilterMode = False
　　myA.AutoFilter
　　
　　For Each ct In vCols
　　　　myA.AutoFilter Field:=ct, Criteria1:="="
　　Next
　　　　　　
　　Set myR = Intersect(ActiveSheet.AutoFilter.Range, ActiveSheet.AutoFilter.Range.Offset(1))
　　If Not myR Is Nothing Then myR.EntireRow.Delete
　　
　　myR.AutoFilter
　　Set myA = Nothing
　　Set myR = Nothing
　　
　　Application.ScreenUpdating = True
　　
　　MsgBox "処理が完了しました"
　　
End Sub

Private Function checkCols(mCols As Long) As Variant
　　Dim a As Range, b As Range
　　Dim k As Long
　　Dim v() As Variant
　　Dim mc As Boolean
　　ReDim v(1 To mCols)
　　For Each a In Selection.Areas
　　　　For Each b In a.Rows(1).Cells
　　　　　　k = k + 1
　　　　　　v(k) = b.Column
　　　　　　If Cells(2, b.Column).MergeCells Then mc = True
　　　　Next
　　Next
　　If mc Then
　　　　checkCols = False
　　Else
　　　　ReDim Preserve v(1 To k)
　　　　checkCols = v
　　End If
End Function


	【70145】Re:列が空白ならば削除したい

ごん - 11/10/17(月) 11:42 -


	引用なし

	パスワード

▼UO3 さん：

（大変です！！　＃＄％？）

回答ありがとうございます。
列ではなくて、行がごっそり消えてしました。


	【70146】Re:列が空白ならば削除したい

ごん - 11/10/17(月) 11:48 -


	引用なし

	パスワード

▼UO3 さん：
回答ありがとうございます。

（あわわわ”＃＄％＆）

列ではなくて行が消えてしまいました。


	【70148】Re:列が空白ならば削除したい

UO3 - 11/10/17(月) 11:57 -


	引用なし

	パスワード

▼ごんさん：

わぁ、ごめんなさ～い！！！！
指定列の行が全て空白ならその行を削除してました。
すべて忘れてください。
列バージョンのコード、出来次第アップします。


	【70149】Re:列が空白ならば削除したい

UO3 - 11/10/17(月) 12:48 -


	引用なし

	パスワード

▼ごんさん：

ご迷惑をおかけしました。
列バージョンです。
列処理ということになると、フィルターは適していないと思われますので配列処理。
ただし、データは処理されますが、２行目で結合されているセルはそのままになりますので
２行目結合列を対象列とした場合、具合が悪いケースがでてくるかもしれません。
配列を使わず、物理的な列削除を行えば、この心配はなくなりますが、できればこのままにしたいですねぇ。

Sub SampleV2()
'配列方式
　　Dim myA As Range
　　Dim lCell As Range
　　Dim z As Long
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim w() As Variant
　　Dim vCols As String
　　Dim allB As Boolean
　　
　　With ActiveSheet.UsedRange
　　　　Set lCell = .Cells(.Cells.Count)
　　End With
　　Set myA = Range("A3", lCell)
　　vCols = getCols(lCell.Column)
　　ReDim w(1 To lCell.Row, 1 To lCell.Column)
　　
　　For j = 1 To lCell.Column
　　
　　　　allB = False
　　　　If InStr(vCols, vbTab & j & vbTab) > 0 Then
　　　　　　If WorksheetFunction.CountBlank(myA.Columns(j)) _
　　　　　　　　　　　　　　　　　　= myA.Rows.Count Then allB = True
　　　　End If
　　　　
　　　　If Not allB Then
　　　　　　k = k + 1
　　　　　　For i = 1 To lCell.Row
　　　　　　　　w(i, k) = Cells(i, j).Value
　　　　　　Next
　　　　End If
　　　　
　　Next
　　
　　Range("A1").Resize(UBound(w, 1), UBound(w, 2)).Value = w
　　MsgBox "処理が完了しました"
　　
End Sub


	【70150】Re:列が空白ならば削除したい

kanabun - 11/10/17(月) 12:53 -


	引用なし

	パスワード

▼ごんさん：横入り失礼します。 >例えば、C列～F列を選択しマクロを実施すると、C列からF列の３行目以降が空白で何も書かれていなければ、その列は削除してしまいたい。列全体を選択して実行という条件で、 Sub 選択列削除() 　　Dim c As Range 　　Dim i As Long, L As Long 　　　　If TypeName(Selection) <> "Range" Then Exit Sub 　　L = Rows.Count 　　If Selection.Rows.Count <> L Then 　　　　MsgBox "列全体を選択してください" 　　　　Exit Sub 　　End If 　　　　Application.ScreenUpdating = False 　　With Selection 　　　　For i = .Columns.Count To 1 Step -1 　　　　　　Set c = .Columns(i) 　　　　　　If c.Cells(L).End(xlUp).Row < 3 Then 　　　　　　　　c.Delete 　　　　　　End If 　　　　Next 　　End With 　　Application.ScreenUpdating = True End Sub ※かんちがいなら、スルーしてください。


	【70151】Re:列が空白ならば削除したい

ごん - 11/10/17(月) 13:57 -


	引用なし

	パスワード

▼UO3 さん：

回答ありがとうございます。

以下のところでエラー（型が一致しません）で止まってしまいます。

これは新規作成したファイルでも起こります。

>　　vCols = getCols(lCell.Column)


	【70152】Re:列が空白ならば削除したい

ごん - 11/10/17(月) 15:59 -


	引用なし

	パスワード

▼kanabun さん：
回答ありがとうございます。

２行目に結合セルがあっても、ちゃんと動くところが良いです。

また、これは私以外の人が使うということは無いので、時間がかかってもOKです。


	【70156】Re:列が空白ならば削除したい

UO3 - 11/10/17(月) 17:40 -


	引用なし

	パスワード

▼ごんさん：

ごめんなさい。
一緒に使う、getCols　の中をがらっとかえたのですが、
それをアップするのを忘れていました。
新しいgetCols　以下です。

Private Function getCols(mCols As Long) As String
　　Dim a As Range, b As Range
　　Dim s As String
　　For Each a In Selection.Areas
　　　　For Each b In a.Rows(1).Cells
　　　　　　s = s & vbTab & b.Column
　　　　Next
　　Next
　　getCols = s & vbTab
End Function


	【70159】Re:列が空白ならば削除したい

ごん - 11/10/18(火) 9:06 -


	引用なし

	パスワード

▼UO3 さん：
回答ありがとうございます。

今度はちゃんと動きました。
但し、２行目に結合セルがあって、その中のどこかの列が削除されても、
結合セルは、そのまま残るのですね。

結合セルの列も削除されると最高なのですが。


	【70166】Re:列が空白ならば削除したい

UO3 - 11/10/18(火) 10:27 -


	引用なし

	パスワード

▼ごんさん：

>結合セルの列も削除されると最高なのですが。

そうですね。
で、こうするには、上でコメントしましたように、配列での上書きではなく
（自分としては好きじゃないんですが）物理的な列の削除を行うことになりますね。
列削除コードについてはすでにkanabunさんからご提示がありますので、かわりばえがないのですが
私のコードを踏まえて「無理やり」対応するなら以下でしょうか。

Sub Sample3()
'列削除方式
　　Dim myA As Range
　　Dim lCell As Range
　　Dim z As Long
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim vCols As String
　
　　Application.ScreenUpdating = False
　　
　　With ActiveSheet.UsedRange
　　　　Set lCell = .Cells(.Cells.Count)
　　End With
　　Set myA = Range("A3", lCell)
　　vCols = getCols(lCell.Column)
　
　　For j = lCell.Column To 1 Step -1
　
　　　　If InStr(vCols, vbTab & j & vbTab) > 0 Then
　　　　　　If WorksheetFunction.CountBlank(myA.Columns(j)) _
　　　　　　　　　　= myA.Rows.Count Then Columns(j).Delete
　　　　End If
　　Next
　　
　　Application.ScreenUpdating = True
　　
　　MsgBox "処理が完了しました"
　
End Sub

Private Function getCols(mCols As Long) As String
　　Dim a As Range, b As Range
　　Dim s As String
　　For Each a In Selection.Areas
　　　　For Each b In a.Rows(1).Cells
　　　　　　s = s & vbTab & b.Column
　　　　Next
　　Next
　　getCols = s & vbTab
End Function


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

2077 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free