VBAの勉強を始めてみた

色々試しています。

空白以外のセルを一瞬でカウントするには?(Tips-5)

VBAの勉強を始めて、これまでに学んだことや、思いついたアレやコレをメモっておきます。

 

今回は、VBAで、セルにデータが有るか無いか(または特定のデータが有るか無いか、でもいい)を調べて、そのデータ数をカウントする方法についてです。

まず、下のように、For Each ~Next を使って A1:Z1048576 の範囲にデータがいくつ存在しているかをカウントしてみようと思います。
セルが空白ではない場合に、cnt を +1 します。

Sub test1()

    For Each myRange In Range("A1:Z1048576")
        If myRange.Value <> "" Then
            cnt = cnt + 1
        End If
    Next myRange
    
End Sub

 

おっと、その前に、処理にどのくらい時間がかかったのかを調べるために、時間計測できる仕掛けを組み込んでおきましょう。

Sub test1()

    StartTime = Time

    For Each myRange In Range("A1:Z1048576")
        If myRange.Value <> "" Then
            cnt = cnt + 1
        End If
    Next myRange
    
    StopTime = Time
    MsgBox "処理にかかった時間は" & vbCrLf & Minute(StopTime - StartTime) _
    & "分" & Second(StopTime - StartTime) & "秒"
    
End Sub

 

さあ、これでかかった時間は・・・・・・、

f:id:kouten0430:20180616165838j:plain

1分58秒

・・・・・・結構、かかったね(@_@;)

 

次は、A1:Z1048576 の範囲を配列に代入してから、配列をループして調べる方法を試してみます。配列の中身が空白ではない場合に、cnt を +1 します。

Sub test2()

    StartTime = Time

    Tdim = Range("A1:Z1048576")
    
    For i = 1 To 1048576
        For j = 1 To 26
            If Tdim(i, j) <> "" Then
                cnt = cnt + 1
            End If
        Next j
    Next i
    
    StopTime = Time
    MsgBox "処理にかかった時間は" & vbCrLf & Minute(StopTime - StartTime) _
    & "分" & Second(StopTime - StartTime) & "秒"
    
End Sub

 

かかった時間は・・・・・・、

f:id:kouten0430:20180616170038j:plain

5秒

圧倒的に速くなりましたよ!

 

この結果から、配列へのアクセスが速いこと(言い換えればループの都度、セルへアクセスすることが時間のかかること)が分かります。
ループというのは掛け算であり、ループの中に入っている処理が少し重いだけで、ループ回数によってはとんでもない時間を要してしまうんですよね・・・・・・。

 

でも、セルにデータが有るか無いかを調べるのであれば、もっと速い方法がありますよね?

それは、ワークシート関数を利用することです。test1、test2と同じ処理をワークシート関数を使って、書き直してみましょう。
CountIfで、空白以外のセル数をカウントさせます。

Sub test3()

    StartTime = Time

    cnt = WorksheetFunction.CountIf(Range("A1:Z1048576"), "<>")
    
    StopTime = Time
    MsgBox "処理にかかった時間は" & vbCrLf & Minute(StopTime - StartTime) _
    & "分" & Second(StopTime - StartTime) & "秒"
    
End Sub

 

かかった時間は・・・・・・、

f:id:kouten0430:20180616170224j:plain

0秒

速い!しかも、コードがすっきりするというオマケつき。

 

test1~3について、それぞれにかかった時間をまとめると下のようになります。 

方法 時間
For Each ~Next で1セルずつ調べる 1分58秒
配列に格納してから調べる 5秒
ワークシート関数で調べる 0秒

 

こうやって見ると、ワークシート関数が圧倒的に速いんですよね。

いや、けして、ワークシート関数利用推進派の回し者ではありませんよ。

 

おまけ:
今回のコードでは、A1:Z1048576 のセル範囲を試験的に調べましたが、じゃあ、A1:XFD1048576 の範囲(要するにシート内のすべてのセル)だったらどのくらい時間がかかるの?ということで、補足しておきます。
私のPCスペックでは、test1のケースで、単純計算で20時間かかり、test2のケースでは、メモリ不足のためテストすることすらできません。
しかし、test3のワークシート関数であれば、なんと!それでも 0秒 で処理が完了してしまいます。普段、ワークシート関数を使う分には何の疑問も抱きませんが、こうやって他の方法と比較してみると、「どうやって処理してるの?」と不思議に思ったりもします。

 

次回は、ワークシート関数以外で、ループ処理をなるべく使わずに済む方法を模索したり、ループ処理をどうしても使わなければならない場面で、ループ回数の掛け算の被乗数側となる処理をできる限り軽くする方法などについて考えてみたいと思います(@_@;)

InputBoxのキャンセル判定について(Tips-4)

VBAの勉強を始めて、これまでに学んだことや、思いついたアレやコレをメモっておきます。

 

今回は、InputBoxでキャンセルを押された場合の判定についてです。

InputBoxでキャンセルを押されたときに、何らかの処理(例えばプロシージャを終了するとか)をさせるために、下記のような条件分岐を入れることがあると思います。

Sub test()
    tmp = InputBox("何か入力して下さい")
        If tmp = "" Then
            Exit Sub
        End If
End Sub

 

InputBox関数でキャンセルを押された場合の戻り値は、空白(長さ0の文字列)です。
なので、変数の中身が空白であった場合は、条件分岐で Exit Sub をさせるわけです。

では、戻り値に空白そのものを使用したい場合はどうでしょう?
上記のコードでInputBoxを空白のままでOKしても、結局、変数の中身は空白であり、キャンセルと同じく Exit Sub されてしまいます。

 

このようなケースでは、InputBox関数ではなく、InputBoxメソッドを使用すると便利です。

InputBoxメソッドでキャンセルを押された場合は、戻り値にBoolean型の False が返ってきますので、変数の型が Variant であれば、下記のように条件分岐させることができます。

Sub test()
    tmp = Application.InputBox("何か入力して下さい")
        If TypeName(tmp) = "Boolean" Then
            Exit Sub
        End If
End Sub

 

TypeName関数で変数のデータ型を調べ、Boolean型であれば条件分岐で Exit Sub するようにしています。

では、変数をVariant型ではなく、数値型や文字列型などで宣言した場合はどうなるでしょうか?
やってみましょう。
変数を数値型にして、キャンセルした場合は False に該当する数値の 0 が入るので、

Sub test()
    Dim tmp As Integer
    
    tmp = Application.InputBox("何か入力して下さい")
        If tmp = 0 Then
            Exit Sub
        End If
End Sub

 

のように条件分岐させることができます。

ではでは、変数を文字列型にした場合はどーでしょう?
変数を文字列型にして、キャンセルした場合は False という文字列が入るので、

Sub test()
    Dim tmp As String
    
    tmp = Application.InputBox("何か入力して下さい")
        If tmp = "False" Then
            Exit Sub
        End If
End Sub

 

のように条件分岐させることができます。

ただし、上記二つの例は 0 という数値と、False という文字列が戻り値として扱えなくなってしまうため、理由がなければ、変数は Variant で宣言すれば良いでしょう。

 

ちなみに、InputBoxメソッドはモードレスなので、入力する数値や文字列をセルから選ぶこともできます。

  • モードレス:ダイアログボックスが表示されている間、ダイアログボックス以外の操作もできる状態
  • モーダル:ダイアログボックスが表示されている間、ダイアログボックス以外の操作ができない状態(InputBox関数で表示されるダイアログボックスはモーダル)

 

ダイアログボックスが表示されている状態で、セルを範囲選択すれば、Range(セル範囲)を入力することもできます。
しかし、戻り値をRange型(要するにオブジェクト)にする場合は、必ず先頭に Set をつけて、

Set tmp = Application.InputBox(prompt:="何か入力して下さい", Type:=8)

のように、書く必要があるため、この時点でBoolean型のデータは代入することができなくなってしまいます。
何を言いたいかというと、この Set がついていると、キャンセルしたときに「オブジェクトが存在しないぜ」ってことで、エラーが発生するってことです。

うーん・・・・・・。じゃあ、キャンセル判定どーしようか?

エラーになるっていうことは、変数は空っぽのままのハズなので、次のようにしてみましょう。

Sub test()
    Dim tmp As Range
    
    Set tmp = Application.InputBox(prompt:="何か入力して下さい", Type:=8)
        If tmp Is Nothing Then
            Exit Sub
        End If
End Sub

 

tmp Is Nothing で、オブジェクト変数が空っぽ(Nothing)ならば、条件分岐で Exit Sub させます。

 

え?・・・・・・なんか足りない?

そもそも、エラーが発生した行で処理が止まってしまうので、以下の記述をさらに追加する必要があります。

Sub test()
    Dim tmp As Range
    
    On Error Resume Next
    
    Set tmp = Application.InputBox(prompt:="何か入力して下さい", Type:=8)
        If tmp Is Nothing Then
            Exit Sub
        End If
        
    On Error GoTo 0
    
End Sub

 

On Error Resume Next から下の行は、エラーが発生しても、エラーを無視してそのまま処理を続けるようになります。

そして、On Error GoTo 0 で、On Error Resume Next の効果を解除します。

 

これで、Range型の場合のキャンセル判定もできるようになりましたね! 

 

※Range型のキャンセル判定のケースは インストラクターのネタ帳 というサイトを参考にさせていただきました。

多重ループを一気に抜けるには?(Tips-3)

VBAの勉強を始めて、これまでに学んだことや、思いついたアレやコレをメモっておきます。

 

タイトルのとおりですが、コーディングしていると、入れ子になったループの中から一気に抜け出したい場面があります。
しかし、下記のように、一番内側のループの中で Exit For しても、ループを抜けるのは該当の For ~Next だけで、外側のループまでは抜けることができません。

Sub test()
    For i = 1 To 10
        For j = 1 To 10
            For k = 1 To 10
                If k = 5 Then
                    Exit For
                End If
            Next k
        Next j
    Next i
End Sub

 

こういうとき私は、初心者モード全開で、GoTo を乱用するのですが、

Sub test()
    For i = 1 To 10
        For j = 1 To 10
            For k = 1 To 10
                If k = 5 Then
                    GoTo skip
                End If
            Next k
        Next j
    Next i
    
skip:

End Sub

 

ネットでいろいろ調べていると、可読性が下がるとか、うんぬんとかであまり好まれていないようです。

じゃあどうすればいいのさっ!?ということで、別の方法を学んでみました。

 

Exit For と一緒に、外側のループ終了条件も満たしてあげる方法

Sub test()
    For i = 1 To 10
        For j = 1 To 10
            For k = 1 To 10
                If k = 5 Then
                    i = 10
                    j = 10
                    Exit For
                End If
            Next k
        Next j
    Next i
End Sub

 

フラグを True にし、フラグが True なら条件分岐で外側のループも Exit For する方法

Sub test()
    For i = 1 To 10
        For j = 1 To 10
            For k = 1 To 10
                If k = 5 Then
                    flag = True
                    Exit For
                End If
            Next k
        If flag Then Exit For
        Next j
    If flag Then Exit For
    Next i
End Sub

 

他にもいろいろあると思いますケド、初心者的には、ぱっと見、GoTo が一番わかりやすいように思えるのは気のせい?
でも、一つのコードの中で GoTo を多用すれば、スパゲッティのようにコードが絡み合い、可読性が下がってしまうことでしょう。

どれが正統なやり方なの?って思いますが、組織で決まったお作法(指針?)などがあれば、それに従い、個人レベルであれば本やネットを参考に汎用性やメンテナンス性を高めたり、ミスを防いだりするための、個人ルールを構築するって感じでしょうか。
うーん。まだまだ知らないことが多くありそうですが・・・・・・、「お作法」の存在を気にしすぎて、自由な発想が妨げられないようにもしたい今日この頃であります。

可視セルのみを二次元配列に格納するには?(Tips-2)

VBAの勉強を始めて、これまでに習得したことや、思いついたアレやコレをメモっておきます。

 

結論から言うと、あらかじめ用意されているプロパティやメソッドなどで、可視セル範囲のみをうまいこと二次元配列に格納することはできないようです。(あくまでも、浅学な私が調べたところでは、です)

下記のような、3行目と3列目を非表示にした範囲から、可視セルのデータのみを配列に格納してみましょう。

f:id:kouten0430:20180526120458j:plain

 

まず、一番最初に思いつくのは、
配列 = Selection.SpecialCells(xlCellTypeVisible)
です。
Selection.SpecialCells(xlCellTypeVisible) は、選択範囲の可視セルのみを取得するプロパティなので、これであっさり、可視セルのみを二次元配列に格納できる!と思ったのですが・・・・・・どうもうまくいきません。

ローカルウィンドウで配列の中身を確認すると、このように、1,2,6,7しか取り込まれていません。あれれ?

f:id:kouten0430:20180526120553j:plain

 

さきほどの非表示の行、列を再表示してみましょう。(3行目と、3列目に色をつけてみました)

f:id:kouten0430:20180526120636j:plain


この非表示の行、列を境に右側、下側が配列に取り込まれていないようです。
配列ではなく、Range型のオブジェクト変数に代入してローカルウィンドウで変数の中身を見ると分かるのですが、

この場合、Areas(範囲のひとかたまり)が4つ存在していることが分かります。

f:id:kouten0430:20180526120713j:plain

 

この非表示セルで分断された、4つの範囲のことですね。

f:id:kouten0430:20180526120748j:plain

 

Selection.SpecialCells(xlCellTypeVisible)を受け取る変数が配列だと、左上のAreasしか代入できない仕様のようです。

 

でも、コードをうまいこと組み合わせれば、なんとかできるハズ!ということでやってみました。

可視セル範囲の行数、列数をカウントして、配列の要素数を再定義し、For ~Nextで列・行方向に非表示セルを除いてデータを取り込む作戦です。

しかし、ここでまたAreas問題にぶち当たります。

Selection.SpecialCells(xlCellTypeVisible).Rows.Count で、行数をカウント
Selection.SpecialCells(xlCellTypeVisible).Columns.Count で、列数をカウント
しようとするも、左上のAreasのぶんしかカウントしてくれません。

う~ん。

しかたないので、苦肉の策(?)で、このようにカウントの仕方を変えます。
Selection.Rows(1).SpecialCells(xlCellTypeVisible).Cells.Count で、選択範囲の1行目の可視セル数をカウント
Selection.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count で、選択範囲の1列目の可視セル数をカウント

ふぅ・・・・・・。これでやっと、可視セル範囲の行数、列数をカウントし配列の要素数を再定義することができました。
ここまでくれば、あとはわりとカンタンな気がします。
For ~Next jで列のデータを、For ~Next iで行のデータを順次、二次元配列に取り込みます。

f:id:kouten0430:20180526121109j:plain

コードはコレ

    y = Selection.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
    x = Selection.Rows(1).SpecialCells(xlCellTypeVisible).Cells.Count
    
    ReDim Tdim(1 To y, 1 To x)
    
    dim1 = 1
    dim2 = 1
        
    For i = Selection.Row To Selection.Rows(Selection.Rows.Count).Row
        For j = Selection.Column To Selection.Columns(Selection.Columns.Count).Column
            If Rows(i).Hidden = False And Columns(j).Hidden = False Then '非表示セルは処理しない
                Tdim(dim1, dim2) = Cells(i, j).Value
                    dim2 = dim2 + 1
                    If dim2 > x Then
                        dim2 = 1
                        dim1 = dim1 + 1
                    End If
            End If
        Next j
    Next i

 

重要なのは、表示されている列・行のみに処理を行うということです。合わせて、処理ごとに、一次元の要素数に +1 していきます。
jが右端まで来ると、一次元の要素数を1にリセットし、二次元の要素数を繰り上げます(カンタンに言うと、一行下がって左端に戻るようなことです)
これを、jとiが最後の値になるまで繰り返します。(この繰り返しの中で、Ifの条件を満たす回数と、配列の再定義した要素数が一致することがミソです)

ローカルウィンドウで結果を見てみます。

f:id:kouten0430:20180526121335j:plain

うまいこと、選択範囲の可視セルのみが順番どおりに格納されていますね。

他にもっと良い方法があるのかもしれませんが、今の私のレベルで思いつくのはここまでです!

 

余談:
Selection.SpecialCells(xlCellTypeVisible)を、For Each ~Nextでループすると、Areasごとに下のような順で処理が進んでしまうため、選択範囲と同じ並びで二次元配列に格納することができません。

f:id:kouten0430:20180526121619j:plain

結合セルを擬似的に単一セルのように扱うには?(Tips-1)

VBAの勉強を始めてみて、これまでに気づいたことや、習得したこまごました知識などをメモっておこうと思います。

 

下の画像のように、A1:C3を結合したセルがあります。

f:id:kouten0430:20180524221841j:plain

見た目は一つのセルのようですが、実際には9個のセル(A1,B1,C1,A2,B2,C2,A3,B3,C3)が含まれてます。

ここで「テスト」という文字列を変数に格納するためのコードを書いてみようと思うのですが、「テスト」という文字列が入っているのは、実際には結合セルの左上セル(A1セル)のみであり、この結合セルを選択した状態で、For Each ~Nextで処理しようとすると・・・・・・

Sub test()
    Dim V As String
    
    For Each C In Selection
        V = C.Value
        Debug.Print V
    Next C
End Sub

f:id:kouten0430:20180524220326j:plain

「テスト」という文字列が1回と、空白が8回、変数に格納されることになります。(イミディエイトウィンドウで空白が分かるように、ドラッグして選択しています)
結合セルに対しては、結合セルに含まれる全ての単一セルに対してループ処理を行うため、このような結果になります。

 

さて、これを単一セルのように扱うにはどうしたらいいでしょうか?
VBAには結合セルの範囲を取得する MergeAreaプロパティ というものがあります。

Range("A1").MergeArea

と書けば、A1セルが含まれる結合セル範囲を取得することができます。(先の結合セルであれば、単一セルを9個格納したコレクションとして取得されます)


インデックス番号で表すと下の画像のようになります。

f:id:kouten0430:20180524221654j:plain

 

ここで、
Range("A1").MergeArea(1).Address

と書けば、セルA1が含まれる結合セル範囲のインデックス番号1のアドレスを取得します。(返り値は、 $A$1 です)

"A1"の部分が、"B1","C1","A2","B2","C2","A3","B3","C3"に変わろうとも、アドレスを取得するセルはMergeArea(1)のセルなので、返り値はすべて $A$1 になります。

この特性を利用して、次のような条件式を作ってみます。

If 単一セル.Address = 単一セル.MergeArea(1).Address Then

 何らかの処理

End If

 

この、単一セルの箇所に、A1,B1,C1,A2,B2,C2,A3,B3,C3を順に当てはめると、 

A1は  True で、それ以外は False になります。

Range("A1").Address = Range("A1").MergeArea(1).Address ←True
Range("B1").Address = Range("B1").MergeArea(1).Address ←False
Range("C1").Address = Range("C1").MergeArea(1).Address ←False
Range("A2").Address = Range("A2").MergeArea(1).Address ←False
Range("B2").Address = Range("B2").MergeArea(1).Address ←False
Range("C2").Address = Range("C2").MergeArea(1).Address ←False
Range("A3").Address = Range("A3").MergeArea(1).Address ←False
Range("B3").Address = Range("B3").MergeArea(1).Address ←False
Range("C3").Address = Range("C3").MergeArea(1).Address ←False


つまり、これを利用してセルA1(結合セルの左上)にのみ処理を行う、という条件を作ることができるのです。

For Each ~Next的に書くと次のようになります。

Sub test()
    Dim V As String
    
    For Each C In Selection
        If C.Address = C.MergeArea(1).Address Then
            V = C.Value
            Debug.Print V
        End If
    Next C
End Sub

f:id:kouten0430:20180524222650j:plain

このコードを実行した結果、「テスト」という文字列が1回、変数に格納されるだけでプログラムが終了します。(イミディエイトウィンドウには、テストという文字列のみ出力されています)

 

このような条件を組み込めば、結合セルを擬似的に単一セルのように扱うことができますね!

コピーしたときに自動的に入るTabを、それぞれ好きな文字に変えてクリップボードへ転送する

通常、エクセルで下図のようなデータ範囲をコピーし、メモ帳などに貼り付けるとこんな感じになると思います。

f:id:kouten0430:20180520132349j:plain

f:id:kouten0430:20180520132321j:plain

 

これは、Tabによってフィールドごとに区切られた状態でコピーされるからであり、逆に言えば、これを再度エクセルに貼り付けることも可能な訳です。(Tabが列の区切りとして、改行が行の区切りとして認識されるからです)

ただ、これだと任意のデータを別のアプリケーションなどに、テキストとしてさくっとコピペするには若干の加工が必要になります。
なので、マクロを組んで、列ごとのTabを別の好きな文字に変えて、コピーしようじゃないかヽ(‘ ∇‘ )ノというのが、今回の記事の趣旨です。

B3からE8の範囲を選択して、通常のコピーを行うと冒頭の画像のようになりますが、マクロを使って選択範囲の列数(+1)分のInputBoxを表示し、ユーザーに好きな文字を入力してもらいます。(画像の例であれば、4列+1=5で、5回のInputBoxが表示されることになります)

f:id:kouten0430:20180520132549j:plain

 

各フィールドごとにInputBoxで入力した文字列がTabに取って代わってクリップボードに転送されるので、こんな感じでコピペすることができるようになります。

f:id:kouten0430:20180520132630j:plain


文字を入れる必要がなければ、InputBoxは空白でOKしてもかまいません。
表示されるInputBoxの回数を選択範囲の列数+1としたのは、先頭と末尾にも文字を入れることができたほうが便利だと思ったからです。

なお、コピーしようとする範囲がフィルタリングされたものであっても、可視セル範囲(画面上に見えているセル)のみをコピーできるように工夫してあるので安心です。 

 

Sub 列を各指定文字で行を改行で区切りクリップボードへ転送する()
    '選択された矩形範囲のデータを、列を各指定文字で、行を改行で区切りクリップボードへ転送します
    '行の冒頭、末尾にも文字列を入れることができます。不要ならInputBoxで空白を指定して下さい。
    Dim y As Long
    Dim x As Long
    Dim Tdim() As String
    Dim dim1 As Integer
    Dim dim2 As Integer
    Dim j As Long
    Dim i As Long
    Dim myRange As Range
    Dim dc() As String
    Dim V As String
    Dim myLib As Object
    Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  '参照設定なしでDataObjectのインスタンスを生成する
    
    If Selection.Areas.Count > 1 Then   '複数の矩形範囲が選択されている場合は終了する
        MsgBox "一つの矩形範囲のみ選択して再度実行して下さい。"
        Exit Sub
    End If
    
    
    '---ここから可視セル範囲を二次元配列に格納する処理---
    
    y = Selection.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
    x = Selection.Rows(1).SpecialCells(xlCellTypeVisible).Cells.Count
    
    ReDim Tdim(1 To y, 1 To x)
    
    dim1 = 1
    dim2 = 1
        
    For i = Selection.Row To Selection.Rows(Selection.Rows.Count).Row
        For j = Selection.Column To Selection.Columns(Selection.Columns.Count).Column
            If Rows(i).Hidden = False And Columns(j).Hidden = False Then '非表示セルは処理しない
                Tdim(dim1, dim2) = Cells(i, j).Value
                    dim2 = dim2 + 1
                    If dim2 > x Then
                        dim2 = 1
                        dim1 = dim1 + 1
                    End If
            End If
        Next j
    Next i
    
    '---ここまで---
    
    
    ReDim dc(1 To UBound(Tdim, 2) + 1)  '+1は末尾に挿入する文字列を格納するため
    
    For j = 1 To UBound(Tdim, 2) + 1
        If j < UBound(Tdim, 2) + 1 Then
            dc(j) = Application.InputBox(prompt:=j & "列目の前に挿入する文字列", Type:=2)
                If dc(j) = "False" Then
                    Exit Sub
                End If
        Else
            dc(j) = Application.InputBox(prompt:="末尾に挿入する文字列", Type:=2)
                If dc(j) = "False" Then
                    Exit Sub
                End If
        End If
    Next j

    For i = 1 To UBound(Tdim, 1)
        For j = 1 To UBound(Tdim, 2)
            If j < UBound(Tdim, 2) Then '選択範囲の最終列以外の処理
                V = V & dc(j) & Tdim(i, j)
            Else    '選択範囲の最終列の処理
                V = V & dc(j) & Tdim(i, j) & dc(j + 1) & vbCrLf
            End If
        Next j
    Next i
    
    V = Left(V, Len(V) - 2) '最終行の改行区切りを取り除く(CrLfは2文字)

    myLib.SetText V  '変数の値をDataObjectに格納する
    myLib.PutInClipboard 'DataObjectのデータをクリップボードに格納する
    
End Sub

※SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら

 

※マクロの使い方

  • コピーしたいデータ範囲を選択する
  • マクロを実行する
  • 表示されるInputBoxに、それぞれ好きな文字列を入力する
  • データがクリップボードに転送されるので、お好きな所にペーストして下さい

 

※プログラムの大まかな流れ(不要な方は読み飛ばして下さい)

  • 各変数の宣言
  • 参照設定なしでDataObjectのインスタンスを生成する
  • 二つ以上の範囲(Areas)を選択している場合はプログラムを終了する
  • 選択範囲(可視セルのみ)を二次元配列(Tdim)に格納する
  • 各指定文字を入れるための配列(dc)を、二次元配列(Tdim)の二次元の最大値+1で再定義する ※+1は列の末尾を表す
  • For ~Nextで、jが選択範囲(可視セルのみ)の列数+1になるまでのループ開始
  • 列間ごとの指定文字を入力するためのInputBoxを表示する(For ~Next j内の処理)
  • For ~Next jの終了
  • For ~Nextで、iが二次元配列(Tdim)の二次元(列)の最大値になるまでのループ開始
  • For ~Nextで、jが二次元配列(Tdim)の一次元(行)の最大値になるまでのループ開始(For ~Next i内の処理)
  • 最終列以外は、変数Vに、変数V & 各指定文字 & 各可視セルの値を格納する(For ~Next j内の処理)
  • 最終列は、変数Vに、変数V & 各指定文字 & 各可視セルの値 & 末尾用の指定文字 & 改行 を格納する(For ~Next j内の処理)
  • For ~Next jの終了
  • For ~Next iの終了
  • Left関数を使って、変数Vから一番最後の改行を取り除く
  • 変数Vの値をクリップボードに格納する
  • プログラムの終了

リストを使用して新規フォルダを大量に作成する

今回はエクセルのリストを使用して、Windowsの新規フォルダを大量に作成してみようと思います。
新規フォルダの作成には、MkDirステートメントを使用します。

MkDir Path:=新しく作成するフォルダ名

 

MkDirステートメントは引数に指定された文字列をフォルダ名にして新規フォルダを作成します。試しに、新しく作成するフォルダ名として、下記のリスト(1~100までの数字)を使用してみたいと思います。

f:id:kouten0430:20180513133412j:plain

f:id:kouten0430:20180513134512j:plain

ユーザーが選択したセル範囲を、Rangeや配列などで取り込み、For Each ~Nextで順番に各セルの値を取り出し、MkDirステートメント新しく作成するフォルダ名の引数にはめ込んでいきます。

 

f:id:kouten0430:20180513134636j:plain

あれ?もう出来たん?というくらい、あっという間に、リストをフォルダ名にして新規フォルダを作ることができます。

 

以下の文字はフォルダ名として使えないので注意が必要です。
\ / : * ? " < > |

 

Sub リストを使用して新規フォルダを作成する()
    Dim mb As Integer
    Dim Dn As String
    Dim myRange As Range
    Dim ct As Long
    
    mb = MsgBox(prompt:="選択中のセルの値をフォルダ名にして、新規フォルダを作成します。", Buttons:=vbYesNo)
        If mb = 7 Then  '「いいえ」を選択した場合はプロシージャを終了する
            Exit Sub
        End If
            
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "新規フォルダを作成する場所(パス)を指定して下さい"
        
        If .Show = -1 Then
            Dn = .SelectedItems(1)
        Else
            Exit Sub
        End If
    
    End With
    
    For Each myRange In Selection.SpecialCells(xlCellTypeVisible)   '可視セルのみに処理を行う
        If myRange.Address = myRange.MergeArea(1).Address Then   '結合セルの場合は左上の値のみ取り出す
            If myRange.MergeArea(1).Value <> "" Then 'セルの値が空白以外の場合のみ処理を行う
                If Dir(Dn & "\" & CStr(myRange.MergeArea(1).Value), vbDirectory) = "" Then '同名フォルダが存在しない場合のみ処理を行う
                    MkDir Path:=Dn & "\" & CStr(myRange.MergeArea(1).Value) '新規フォルダを作成する
                    ct = ct + 1
                End If
            End If
        End If
    Next myRange
    
    MsgBox "処理成功:" & ct & " フォルダ"

End Sub

※SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。 

 

※プログラムの大まかな流れ

  • 各変数の宣言
  • メッセージボックスで「選択中のセルの値をフォルダ名にして、新規フォルダを作成します。」のメッセージを表示し、いいえを選択された場合、プログラムを終了する。
  • Application.FileDialogで、フォルダ選択のダイアログを表示し、選択されたフォルダのパスを文字列として変数に格納する
  • マクロ実行前に選択されていた可視セル範囲を、For Each ~Nextで順次取り込む
  • セルの値が空白以外のみ次の処理を行う(For Each ~Next内の処理)
  • Dir関数でセルの値と同名のフォルダを検索し、存在しない場合のみ次の処理を行う(For Each ~Next内の処理)
  • MkDirステートメントで、パス+セルの値をフォルダ名として、新規フォルダを作成する(For Each ~Next内の処理)
  • 処理件数をカウントする(For Each ~Next内の処理)
  • For Each ~Nextの終了
  • 処理件数をメッセージ表示してプログラムを終了する