「今さら」なんてない

「自分にもできそう」を伝播させるブログ

開始予定/終了予定/見積時間のうち、どれか2つが埋まったら残りの1つを自動計算する【ExcelVBA】

またもスケジュール管理系です。

スケジュール入力の際、
開始予定/終了予定/見積時間の3要素で決めると思うのですが、
2つが埋まれば残り1つは自動的に決まるじゃないですか?

こんな感じ↓

入力項目
開始予定と終了予定 会議など拘束時間がわかっているもの
終了予定と見積時間 締切、電車の到着時刻基準で検索
開始予定と見積時間 自分主体で組む予定、電車の発車時刻基準で検索

なのに普通のExcelだといちいち3つ目も入力しなきゃいけない...

こういう頻出動作が生む微弱なストレスが
塵も積もればなんとやらで地味に負荷をかけている
ものです。
この手の無意識レベルのストレスダイエットをすごく大事だと思っているので作りました。

ご自由にお使いください!

概要

タイトルの通り、
「開始予定/終了予定/見積時間のうち、どれか2つが埋まったら残りの1つを自動計算する」

これだけです。

コード

シートモジュール

Const Col見積 = "G"
Const Col開始 = "H"
Const Col終了 = "I"

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Column
        Case Is = CNumAlp(Col開始), CNumAlp(Col終了)
            Call 四桁入力したら時刻に変換(Target)
            Call 見積等計算(Target)
    End Select
End Sub

標準モジュール

Const Col締切 = "F"
Const Col予定 = "F"
Const Col見積 = "G"
Const Col開始 = "H"
Const Col終了 = "I"
Const Col完了 = "J"

Public flag As Boolean

Sub 見積等計算(ByVal Target As Range)
  On Error Resume Next
  If flag = False Then: GoTo Cancel
  
  With Target
  Select Case .Column
    Case Is = CNumAlp(Col見積)                 '見積入力時
      If IsNumeric(.Value) = False And .Value <> "" Then
          MsgBox "数値を入力してください"
      ElseIf Cells(.Row, Col見積).Value <> "" Then                                        '見積時間列が空白でなければ
        If Cells(.Row, Col開始).Value <> "" And Cells(.Row, Col終了).Value = "" Then      '開始時刻が決まっており、終了時刻が未定なら
          Cells(.Row, Col終了).Value = _
            DateAdd("n", Cells(.Row, Col見積).Value, Cells(.Row, Col開始).Value)          '終了時刻を計算する
        ElseIf Cells(.Row, Col終了).Value <> "" And Cells(.Row, Col開始).Value = "" Then  '終了時刻が決まっており、開始時刻が未定なら
          Cells(.Row, Col開始).Value = _
            DateAdd("n", Cells(.Row, Col見積).Value * (-1), Cells(.Row, Col終了).Value)   '開始時刻を計算する
      End If
      End If
  
    Case Is = CNumAlp(Col開始)                '開始入力時
      If IsDate("01/01/01 " & Format(.Value, "hh:mm:dd")) = False And .Value <> "" Then
          MsgBox "時刻を入力してください"
      ElseIf Cells(.Row, Col見積).Value = "" And _
             Cells(.Row, Col終了).Value <> "" Then
          Cells(.Row, Col見積).Value = _
              DateDiff("n", Cells(.Row, Col開始).Value, Cells(.Row, Col終了).Value)
      ElseIf Cells(.Row, Col見積).Value <> "" And _
             Cells(.Row, Col終了).Value = "" Then
          Cells(.Row, Col終了).Value = _
              DateAdd("n", Cells(.Row, Col見積).Value, Cells(.Row, Col開始).Value)
         End If
  
    Case Is = CNumAlp(Col終了)               '終了入力時
      If IsDate("01/01/01 " & Format(.Value, "hh:mm:dd")) = False And .Value <> "" Then
          MsgBox "時刻を入力してください"
      ElseIf Cells(.Row, Col見積).Value = "" And _
         Cells(.Row, Col開始).Value <> "" Then
          Cells(.Row, Col見積).Value = _
              DateDiff("n", Cells(.Row, Col開始).Value, Cells(.Row, Col終了).Value)
      ElseIf Cells(.Row, Col見積).Value <> "" And _
             Cells(.Row, Col開始).Value = "" Then
          Cells(.Row, Col開始).Value = _
              DateAdd("n", Cells(.Row, Col見積).Value * (-1), Cells(.Row, Col終了).Value)
      End If
  End Select
  End With
Cancel:
End Sub

Function CNumAlp(va As Variant) As Variant '列文字⇔数値を相互変換する関数
    '引用元:https://ateitexe.com/change-alphabet-integer/
  Dim al As String
 
  If IsNumeric(va) = True Then '数値だったら
    al = Cells(1, va).Address(RowAbsolute:=False, ColumnAbsolute:=False) '$無しでAddress取得
    CNumAlp = Left(al, Len(al) - 1)
  Else 'アルファベットだったら
    CNumAlp = Range(va & "1").Column '列番号を取得
  End If
End Function

コードの解説

シートモジュール:Changeイベント

ここでやるのは
Call 見積等計算(Target)で標準モジュールを呼び出すだけです。
(Target)というのはChangeイベントで変更したセルを渡すものになります。

Call 四桁入力したら時刻に変換(Target)

こちらは以前紹介した別のマクロを呼び出すものです。

yoshino-ya.hatenablog.com


ちなみにこちらで出てきた伏線

Case .Value = "": flag = False '見積等計算プロシージャで自動計算させない
こちらは今回のもの単独では意味がありませんが、
別のプロシージャで、時刻の計算を行うのを防ぐためにある行です。

これが今回の見積等計算プロシージャです。


標準モジュール

変数宣言:列の指定 ※ここは人それぞれ設定が必要です

モジュールの先頭に宣言すると、そのモジュール内の共用変数になります。

接頭語にPublicをつけると他のモジュールでも共用化され、
Constをつけると定数として宣言できます。
行数や列数の指定や、定型文などに使えます。

Const Col見積 = "G"
Const Col開始 = "H"
Const Col終了 = "I"

Public flag As Boolean

プロシージャ名(ByVal Target As Range)のByVal Target As Rangeって何ぞ?

シートモジュールから渡されたTarget(変更されたセル)に対し処理をします。
セルを格納する変数なのでRange型です。

ByValは値渡しの意で、
もう一つ参照渡しByRefというものがありますが、
詳しくはこちらをどうぞ Office TANAKA - Excel VBA Tips[参照渡しと値渡し]


そういえば、As~(~として)って中学?の英語でやりましたよね?
他にもIfやThen、Else、Each、in、Toなど、
こういう接続語や前置詞などは英語をやっている最中でも
こうしてプログラミングなどを通して使ってみて
その語のもつイメージなどを習得していくのは有効だよなー
と思っています。

英語が苦手な子にはプログラミングをさせよう!
(まあ僕はプログラミングの方が苦手でしたが)


条件分岐:列の埋まり具合で判別

おなじみSelect文で仕分けます。

Select Case .Column
  Case Is = CNumAlp(Col見積)

変更されたセルの列によって仕分けます。
CNumAlp(Col見積)という謎の関数は後述します。


If IsNumeric(.Value) = False And .Value <> "" Then
  MsgBox "数値を入力してください"

これは入力された値が数値でなく、空白だった際に処理する行です。


実行する場合は次のIf分で仕分けられます。
各行の説明はコメント文の通りです。
長ったらしいですが、やっていることは単純力作業です。

ElseIf Cells(.Row, Col見積).Value <> "" Then                                        '見積時間列が空白でなければ
  If Cells(.Row, Col開始).Value <> "" And Cells(.Row, Col終了).Value = "" Then      '開始時刻が決まっており、終了時刻が未定なら
    Cells(.Row, Col終了).Value = _
      DateAdd("n", Cells(.Row, Col見積).Value, Cells(.Row, Col開始).Value)          '終了時刻を計算する
  ElseIf Cells(.Row, Col終了).Value <> "" And Cells(.Row, Col開始).Value = "" Then  '終了時刻が決まっており、開始時刻が未定なら
    Cells(.Row, Col開始).Value = _
      DateAdd("n", Cells(.Row, Col見積).Value * (-1), Cells(.Row, Col終了).Value)   '開始時刻を計算する
End If

ユーザー定義関数:列文字⇔数値を相互変換する関数

CellsColumnで変数から列指定をする際、

例えばJ1セルをしていする場合、

Cells(1,”J")

直接入力の場合はを指定できるのですが、

c="J"
Cells(1,c)

このように一旦変数に格納した列の文字列はCellsに入れるとエラーになります。

変数を介して指定する場合は数値でなれけばなりません。

ここで問題です。
「J」ってアルファベットの何番目?

僕は♪ABCの歌を歌わないと出てきません。

これを列番号の文字列を1列目から数えて何列目かなんて
いちいち数えてられませんし、コードが読みづらいですよね?


そこで素晴らしい変換ツールを作成されている方がいたので拝借しました。 ateitexe.com

これをシートモジュールにも標準モジュールにも組み込んで、
列による条件分岐文を書きやすく、見やすいものにできました!

残課題:複数セルをまとめて変更すると変なポップアップが出る

例えば開始、終了を同時に選択した状態で変更・削除すると
「時刻を入力してください」と言われます。

とは言え一応使えると言えば使えるので大目に見てやってください、、、

個人的感想

多重If文は書いてて楽しくないです
もっとスマートにできないかな、、、

タスクペディア→たすくま リピートタスクに転記【マロ。さんブックマークレット紹介】

昨日、タスクペディアの追加登録に際し、
マロ。さんが以前作られていたブックマークレットの紹介をされていたので
恐縮ながら機能アレンジの注文をしたところ、早速作成していただきました!

ありがとうございます!!!


恐縮ですが、
このスクリプトの感動ポイントを紹介させて頂きます!

ここがスゴい!

プロジェクト名をプロジェクト以外で管理していてもOK!

投資保守休憩緊急などなど、
プロジェクトではなくモード評価軸で利用している方でも
タスクペディアのプロジェクト名を割り当てたリピートタスク
たすくま側で用意しておけば2つのツールが完全に繋がります!

(僕のたすくま遍歴)

昔は僕もたすくまのプロジェクト名に各プロジェクトの名前を当てて使用していたのですが、
だんだん収集がつかなくなるのと、
そもそもプロジェクト割り当てが面倒になってきてしまい、
たすくまの運用がグズグズになってしまっている時期がありました、、、


その後、一部のたすくまやタスクシュートマスターの方々から、
プロジェクトではなくモード評価軸で利用していることを教わり、
模倣するようになりました。

例:投資保守休憩緊急などなど、、、

こうすると割り当てやサマリーがとてもスッキリして、
自分の時間の使い方にフォーカスしやすく
なりました!


が、

1日や1周間程度の計画であればたすくま1本でなんとかなりますが、
いつか未到来自分ボール持ちではないものを含む中長期計画には
たすくま1本ではちとしんどい
のです、、、


こうして時は流れ、、、
いろいろ紆余曲折試してみましたが、
タスクペディア
という素晴らしい中長期計画向けの管理ツール登場により希望の光が!

さらにその後間もなく
タスクペディア→たすくまのスクリプトが公開されました!


しかし、スクリプトの一部が
タスクペディア上のプロジェクト名
→たすくまのプロジェクト
への転記というものだったので、

  • たすくまに合わせると
    タスクペディアが肝心のプロジェクト管理ツールでなくなり、
  • タスクペディアに合わせると
    たすくまがスパゲッティ化する

というジレンマに襲われることに、、、

ここでjavascriptの知識があれば自力でアレンジ出来たのでしょうが、
僕にその力はなく、
デコードして勘でアレンジを試みましたが
頓挫→放置→忘却というオチに至りました、、、


あれから約半年、

Twitter利用頻度upによるツイート収集率upもありますが、
Workflowyのシステム改変による関連スクリプト崩壊時に
マロ。さんとの繋がりが得られた経験のおかげで、
(というかマロ。さんがお声がけしやすい雰囲気を作っていただいただけ)
今回のマロ。さんのツイートへリクエストを送ってみることに、、、 (そして冒頭の回答へ、、、)


謝辞までの前置きが長くなりましたが、
スゴいところの続きを進めます。

報告まとめ力はプロジェクト<<<リピートタスク

たすくまのレポート機能に関して、
まとめられる単位がプロジェクトリピートタスクの2つありますが、

プロジェクト別に合計時間が見たい場合でも、
リピートタスク詳細からレポート送信すれば、
プロジェクト同様の出力が得られます。

ならば
プロジェクトで管理しなくても
リピートタスクでいいじゃないか、

となります。

それどころかリピートタスクなら
実施期間分析もすぐに確認できますし、
合計時間平均セクションごとの棒グラフも得られ、
リピートタスク同士のマージまでできます!
素晴らしい!

プロジェクト発足時にはバラバラだったものや
プロジェクト名のダブリ発覚時のマージがカンタンなのな大きいです。
プロジェクトだとマージもクソもないですし、一括変更もクソ手間です。


間接的にタグ自動付与可能!→タグをプロジェクトに見立てられる!

先日、URLスキームの追加で
日時の指定が可能になりましたが、
タグの付与がまだ対応していません。

この問題も解決してくれました!

指定のリピートタスクにタグを付与しておけばOK!
これだけです。カンタン!


レポート出力時のプロジェクト名見えず問題解消!タグなら見える!

メールやEvernoteへのレポートフォーマットにおいて、
実績と未完一覧にはプロジェクト名が表示されますが、
メモ一覧には表示されません。

逆にタグは実績未完一覧に表示されませんが、
メモ一覧に表示されます。

これは人それぞれの好き好きですが
僕は一覧も見ますがメモ欄の方をよく見返すので
タグの方が便利なのです。


まとめ

レポート機能の有無と
レポートのメモ一覧での表示有無、
たすくまメイン画面での表示状況をまとめるとこうなります。

項目 レポート
単位
レポート
実績・未完一覧
レポート
メモ一覧
たすくま
メイン画面
プロジェクト × タスク名の上
リピートタスク × × タスク詳細画面
タグ × × タスク詳細画面


ここでリピートタスクに予めタグを付与しておけば

項目 レポート
単位
レポート
実績・未完一覧
レポート
メモ一覧
たすくま
メイン画面
プロジェクト × タスク名の上
リピートタスク
+タグ
× タスク詳細画面

この様になって、万々歳!となります!
だからスゴイ!たすくまの弱点を見事に克服しました!


ひとつ難クセをつけられるとすれば、
プロジェクト名がメイン画面一覧から見えなくなることでしょう。

でも、
直近の予定範囲でプロジェクト名が分からなくなることはまずないでしょうし、
正しいタスクシュートの使い方は
原則上から順番になので、
前後の脈絡でおそらく分かりますし、
わからなくなっても詳細画面を開けば見えるので、
使用快適性が損なわれることはないと思います。


あとはGoogleカレンダーでの表示状態まで考慮した場合、こうなります。

項目 レポート
単位
レポート
実績・未完一覧
レポート
メモ一覧
たすくま
メイン画面
Google
カレンダー
プロジェクト × タスク名の上
リピートタスク
+タグ
× タスク詳細画面 ×

カレンダー上でプロジェクト名が見たければ、
スクリプト内部のtaskname=repeat=の後に持ってきて、
リピートタスク名:タスク名と来るように書き換えれば良いかもしれません。
(具体的なやり方というか微調整みたいなのわかりませんが、、、)


以上です!

最後にもう一度:スクリプトのリンクはこちら

note.mu マロ。さん、本当にありがとうございました!

日時の加減算をワンボタンでできるようにしよう!【ExcelVBA】

主にスケジュール管理シート対象にはなりますが、

  • 日付を1日だけ変更したい
  • 数値(見積時間)を少しだけ変更したい

など、リスケ時の頻出動作を簡単化したくないですか?


簡単にできます。
下記コードをExcelにコピペして、
ショートカットを割り当てるだけです。

では早速参りましょう!


概要

選択セルが

  • 日付なら1日ずつ
  • 数値(3桁まで)なら10ずつ ※1桁のものは1ずつ

加減算します。それだけです。


コピペするコード

標準モジュール

Sub 日付や見積や時刻を加算する()
    加減算 (1)
End Sub

Sub 日付や見積や時刻を減算する()
    加減算 (-1)
End Sub
Function 加減算(増減値 As Integer)
    Dim buf
    buf = ActiveCell
    Select Case True
    Case IsDate(buf)                                    '日付
        If buf = "" Then: buf = Date
        buf = DateAdd("d", 増減値, buf)
    Case buf Like "###"                                 '見積時間3桁
        buf = buf + 増減値 * 10
    Case buf Like "##"                                  '見積時間2桁(何故かカンマ区切りでOR条件にできない)
        buf = buf + 増減値 * 10
        If buf < 10 Then: buf = 9
    Case buf Like "#"                                   '見積時間1桁
        buf = buf + 増減値 * 1
        If buf < 1 Then: buf = 1
        If buf > 9 Then: buf = 10
    Case IsDate("01/01/01 " & Format(buf, "hh:mm:dd"))  '時刻
        buf = DateAdd("n", 増減値 * 10, buf)
    End Select 'True
    ActiveCell = buf
End Function

コードの解説

ショートカット設定対象はこの2つ

プロシージャ名 ショートカット例
日付や見積や時刻を加算する ALT+{UP}
日付や見積や時刻を加算する ALT+{DOWN}

ショートカット一括割当方法はこちら

yoshino-ya.hatenablog.com

メイン

Select Case True:複雑な条件分岐はこれ!

Select文って、最初のうちはSelect Case 変数として、
例えばその変数が1の場合は、という場合分けをしたい時は
Case Is =1なんて使い方をするのですが、

Like演算子を使った場合分けをしたいときには
結果がTrueであることを条件にするみたいで、
この記法が手札に加わると、
「余程簡単な条件文でない限りIf文要らなくね?」
って感じになってきます。

いろいろ調べているうちにヒットした、
こちらの記事がわかりやすかったです。 www.sejuku.net

日付と時刻をどう見分けるか

日付も時刻もIsDateだけで判別しようとするとどちらもTrueとなります。
そこでIsDate("01/01/01 " & Format(buf, "hh:mm:dd"))という感じに
いろいろ装飾をつけると時刻のみTrueが返ってくるようになります。
※時刻のみの表記の場合です。


DateAdd:日時の計算

日付同士の計算のDateDiffより簡単で分かりやすいです。

'DateAdd(加減算の単位, 加減算値, 日時データ)'
の通り、単純足し算引き算です。
加減算の単位というのは

  • なのか時間なのか
  • なのかなのか

などの単位時間のことです。
細かいことは下記リンクにありますのでご参照ください。

DateAdd 関数


加減算値の調整をしたい方はこちら

buf = buf + 増減値 * 10

buf = buf + 増減値 * 1
        If buf < 1 Then: buf = 1
        If buf > 9 Then: buf = 10

の中の*10*1をいじってください。

個人的感想

最初はタスク管理ツールとかガッツリ系を題材にしていましたが、
この手のシンプル系に最近ハマっています。


こういう汎用性のあるネタって良いですね。
もっと広まれ、こういうの
もっとラクになれ、みんな

みんな気軽に使って!4桁入力→日付や時刻に自動変換!【ExcelVBA】

Excelは今日の日付や現在時刻は入力できるけど、
他の日時の入力って面倒ですよね?

4桁の数値を入力したらそのまま変換してくれるツールはたくさんあるのに、
Excelでもできないのはおかしいので作りました。

ぜひぜひお気軽にご利用ください!


概要

  • セル内容を変更したら、そのセルの表示形式が時刻なら時刻に変換します。
  • 日付入力については、起動後に出てくるポップアップに
    4桁または6桁で入力すると日付形式で入力されます。
    別途ショートカットを設定ください(→手順参考


コピペするコード

シートモジュールにコピペするやつ

下記コードを指定のシートモジュールにコピペして下さい

Private Sub Worksheet_Change(ByVal Target As Range)
    Call 四桁入力したら時刻に変換(Target)
End Sub

標準モジュールにコピペするやつ

Sub 四桁入力したら時刻に変換(ByVal Target As Range)
    Application.EnableEvents = False '無限ループ対策

    On Error Resume Next
    flag = True 'Falseなら見積等計算プロシージャで自動計算させない
    
    With Target

        If .NumberFormatLocal = "h:mm;@" Then
            Select Case True
            '先頭に0が付く場合は桁数が減るので各パターン用意
            Case .Value Like "#"
                .Value = "00:0" & .Value
            Case .Value Like "##"
                .Value = "00:" & .Value
            Case .Value Like "###"""
                .Value = "0" & Left(.Value, 1) & _
                        ":" & Right(.Value, 2)
            Case .Value Like "####"
                .Value = Left(.Value, 2) & _
                        ":" & Right(.Value, 2)
            Case .Value Like "#:##", "##:##"    '何もしない
            Case .Value = "": flag = False      '見積等計算プロシージャで自動計算させない
            Case Else
                MsgBox "4桁の数値か時刻形式で入力してください"
                flag = False
                .Value = ""
            End Select  'True
        End If  'NumberFormatLocal
    End With    'Target
    Application.EnableEvents = True

End Sub

Sub mmddかyymmddで日付入力()
   Dim buf
   
   buf = InputBox("4桁または6桁で日付を入力してください" & vbCrLf & "(mmdd形式またはyymmdd形式)")
    
    Select Case True
    '先頭に0が付く場合は桁数が減るので各パターン用意
        Case buf = "": GoTo Cancel
        Case buf Like "####"
            buf = Year(Date) & "/" & Left(buf, 2) & "/" & Right(buf, 2)
        Case buf Like "######"
            buf = Left(Year(Date), 2) & Left(buf, 2) & "/" & Mid(buf, 3, 2) & "/" & Right(buf, 2)
        Case Else
            MsgBox "4桁or6桁の数値で入力してください"
            buf = ActiveCell.Value
    End Select
    ActiveCell.Value = buf
Cancel:
End Sub

コードの解説

セル入力イベント

Private Sub Worksheet_Change(ByVal Target As Range)
    Call 四桁入力したら時刻に変換(Target)
End Sub

セルの値が変更されたら四桁入力したら時刻に変換を即実行、これだけです。
あとの細かいことは標準モジュールに任せます。

4桁入力したら時刻に変換するやつ

If .NumberFormatLocal = "h:mm;@" Then

ここで選択セルの表示形式を見ます。
時刻形式h:mm;@なら実行し、そうでなければ悪さはしません。


Select Case True
    '先頭に0が付く場合は桁数が減るので各パターン用意
    Case .Value Like "#"
        .Value = "00:0" & .Value
    Case .Value Like "##"
        .Value = "00:" & .Value
    Case .Value Like "###"""
        .Value = "0" & Left(.Value, 1) & _
                ":" & Right(.Value, 2)
    Case .Value Like "####"
        .Value = Left(.Value, 2) & _
                ":" & Right(.Value, 2)

'先頭に0が付く場合は桁数が減るので各パターン用意とあるように、

文字列形式出でない場合、

  • 0012だと12
  • 0123だと123

となってしまい、そのままだとうまく行かないので
1桁~4桁まで1パターンずつ補正処理を用意します。


Case .Value Like "#:##", "##:##"
Ctrl+:などで最初から時刻形式で入力された場合の例外避け文です。


Case .Value = "": flag = False '見積等計算プロシージャで自動計算させない
こちらは今回のもの単独では意味がありませんが、
別のプロシージャで、時刻の計算を行うのを防ぐためにある行です。
そちらについても近々アップしますのでご利用ください。


Case Elseは頻繁に使うので是非覚えてください!
事前に例外を挙げまくっておき、それ以外は全部処理します。
例外が日本だけなら日本以外全部沈没します。


mmddかyymmddで日付入力するやつ

こちらは自動ではありません。
まずbuf = InputBox("説明文")で入力を求めるポップアップが出るので
4桁または6桁で日付を入力してください。

こちらも時刻同様、Select文で4桁の場合と6桁の場合に補正処理を分けます。
4桁の場合は自動的に今年の日付になります。
別の年を入力されるばあいは6桁入力してください。


ショートカット設定シートに作り方はこちら

Ctrl+:Ctrl'+;はOnkeyメソッドの振り方がわからないので<br> 僕はAlt+ENTER`にしています。

yoshino-ya.hatenablog.com


個人的感想

今回のものは多くの方にご利用いただきたいものになり、
個人的に大満足のネタになりました。
むしろExcelに標準装備されろ!


次回は日付や時刻を加減算するやつをアップするので
今回のものと併せて入力をもっとラクにしましょう!

対神エクセル!指定文字数で改行し直してペーストする

方眼紙エクセルフォーマットで無駄な作業の代表格の一つとして、改行位置の修正があると思うのですが これもサクッとやっちまいたくて作りました。 (非対応の形もあり、完成形ではありませんが)


概要

  • 選択範囲を一度まとめてから、指定文字数ごとに改行し直す
  • 出力は1行1セル
  • 既存の改行位置はそのまま改行位置として残す
    ※ただし改行コードではない改行位置(セル区切り)については非対応
  • 2列以上選択した場合も出力は1列
    (2列以上選択されている場合は実行可否のポップアップが出る)


コピペするコード

Sub 文字数ごとに改行()
    Dim rCell, i, k
    Dim str, strArr() As Variant
    Dim 指定文字数, 開始位置, 既存改行位置
    Dim iniRows, iniColumns
    Dim rc
    
    指定文字数 = InputBox("1行あたりの文字数を入力してください" & vbCrLf & _
        "指定文字数の位置で改行します。", "改行位置設定")
    
    If IsNumeric(指定文字数) = False Then: Exit Sub
    If 指定文字数 < 1 Then: Exit Sub
    
   
    '複数列が選択されていたら警告(実行したい時もあるだろうから実行の余地も残しておく)
        If iniColumns > 1 Then
            rc = MsgBox("複数列まとめて1列に出力されます。" & vbCrLf & _
                "※選択範囲から飛び出た場合、セルが上書きされます。" & vbCrLf & vbCrLf & _
                "選択し直しますか?" & vbCrLf & _
                "「いいえ」を押すと実行します。", _
                vbYesNo + vbExclamation, "注意:2列以上選択されています")
                
            If rc = vbYes Then
                MsgBox "処理を中止します"
                Exit Sub
            End If
        End If
        
    '初期化
        開始位置 = 1
        k = 0
        iniRows = Selection.Rows.Count
        iniColumns = Selection.Columns.Count
    
    '範囲内の文字列をすべて1つの変数に格納する
        For Each rCell In Selection
            str = str & rCell.Value
        Next rCell
    
    '指定文字数ごとに改行コードを入れる
        Do While Len(str) >= 開始位置
            ReDim Preserve strArr(k)
            
                '既存の改行コードが出てきたらすぐ分割
                既存改行位置 = InStr(Mid(str, 開始位置, 指定文字数), vbLf)
                
                If 既存改行位置 > 0 Then
                    strArr(k) = Mid(str, 開始位置, 既存改行位置)
                    開始位置 = 開始位置 + 既存改行位置
                    
                Else
                '改行コードがなければ指定文字数ごとに改行コードを入れる
                    strArr(k) = Mid(str, 開始位置, 指定文字数)
                    開始位置 = 開始位置 + 指定文字数
                
                End If
            k = k + 1
        Loop
        
    '出力
        For i = 0 To k - 1
            Selection(1).Offset(i, 0).Value = strArr(i)
        Next i
        
    '行数が減る場合は、余った範囲を削除する(k+1行目からiniRows)
        If k < iniRows Then
            For i = k To iniRows
                Selection(1).Offset(i, 0) = ""
            Next i
        End If
        '複数列をまとめた場合も2列目以降を削除する
        If iniColumns > 1 Then
            Selection(1).Offset(0, 1).Resize(iniRows, iniColumns).Value = ""
        End If
        
End Sub

コードの解説

冒頭:改行位置(文字数)指定

まずはInputBoxで数値を入力します。

指定文字数 = InputBox("1行あたりの文字数を入力してください" & vbCrLf & _
        "指定文字数の位置で改行します。", "改行位置設定")

入力データが数値でなかったり
1未満だったら処理しないようにします。


If IsNumeric(指定文字数) = False Then: Exit Sub
    If 指定文字数 < 1 Then: Exit Sub

実行可否の確認(2列以上選択時)

        If iniColumns > 1 Then
            rc = MsgBox("複数列まとめて1列に出力されます。" & vbCrLf & _
                "※選択範囲から飛び出た場合、セルが上書きされます。" & vbCrLf & vbCrLf & _
                "選択し直しますか?" & vbCrLf & _
                "「いいえ」を押すと実行します。", _
                vbYesNo + vbExclamation, "注意:2列以上選択されています")
                
            If rc = vbYes Then
                MsgBox "処理を中止します"
                Exit Sub
            End If
        End If

MsgBoxの戻り値(YesかNoか)をrcという変数に格納しておいて、Yesなら実行しないようにする部分です。(連打して誤作動を起こすかもなのでNoを実行トリガにしました)


前処理:範囲内の文字列を1つの変数にまとめる

        For Each rCell In Selection
            str = str & rCell.Value
        Next rCell

とりあえずまとめる系(プレフィックスサフィックス)の処理は元の値=元の値 & 追加分ラクです。


指定文字数ごとに改行コードを入れる

 Do While Len(str) >= 開始位置
    ReDim Preserve strArr(k)
            
        '既存の改行コードが出てきたらすぐ分割
        既存改行位置 = InStr(Mid(str, 開始位置, 指定文字数), vbLf)
                
        If 既存改行位置 > 0 Then
            strArr(k) = Mid(str, 開始位置, 既存改行位置)
            開始位置 = 開始位置 + 既存改行位置
                    
        Else
        '改行コードがなければ指定文字数ごとに改行コードを入れる
            strArr(k) = Mid(str, 開始位置, 指定文字数)
            開始位置 = 開始位置 + 指定文字数
                
        End If
    k = k + 1
Loop

流れとしては

  1. 改行予定の文字数以内に、既存の改行がないか確認
  2. あればそこで配列に分割して格納する
  3. なければ指定文字数の位置で分割する

このとき、次の行のMidの開始位置を更新しておいてあげます。


改行して出力

For i = 0 To k - 1
    Selection(1).Offset(i, 0).Value = strArr(i)
Next i

あとは簡単。配列を順番にセルに出力するだけ。

For文なしでResizeして1発で貼り付けるやり方もあるみたいですが、まだ血肉になってないのでとりあえずこのやり方にしました。


行数が減る場合は、余った範囲を削除する

If k < iniRows Then
    For i = k To iniRows
        Selection(1).Offset(i, 0) = ""
    Next i
End If

'複数列をまとめた場合も2列目以降を削除する
If iniColumns > 1 Then
    Selection(1).Offset(0, 1).Resize(iniRows, iniColumns).Value = ""
End If

これがないとはみ出た部分に文字が残ったままで汚いので掃除します。


残課題:改行コードではない既存の改行位置は未完成

セル内の改行(vbLf)による改行には対応しているのですが、
現状、編集前の状態が

編集前
1行目ぇぇぇえええ
2行目ぇええ
3行目

こんなのだとしたら

5文字で改行すると

編集後
1行目ぇぇ
ぇえええ2
行目ぇええ
3行目

となってしまいます。

本来やりたい姿
1行目ぇぇ
ぇえええ
2行目ぇえ
3行目

こうするにはどうすれば良いんですかね?

指定文字数未満を条件に為た場合、例えば1行10文字のものを15文字に拡張することができなくなります。

んー。意外と闇が深い...
そもそもこんなフォーマットでしがらみを作るなよ...

【ExcelVBA】禁則文字発見機(とまでは行かなかったが例外を除いて半角→全角変換)

何かしらのシステムにインポートする用のファイル
があったとして、

そのシステムが規定する
禁則文字や入力規則などにひっかかって
「インポートできません」
みたいなのありますよね?

今回はインポート前に違反箇所を
自分で探して修正する機能をつくってみました。

概要

  • 選択範囲全域を1文字ずつ巡回して判別
  • 基本的には最後に全角変換をかけるだけ
  • それまでに例外パターンを除外するだけ
  • 今回除外例として挙げたのは英数と一部の記号
  • 全角変換後に禁則文字の置換

コピペするコード

Option Explicit

Sub 選択範囲を作成要領に沿って修正()
    Dim rCell, c
    Dim strAssm, strPart

        '巡回:1文字ずつ例外を弾きながら
            For Each rCell In Selection
                strAssm = Null
                For c = 1 To Len(rCell)
                    strPart = Mid(rCell, c, 1)
                    strAssm = strAssm & 要領チェック(strPart)
                Next c
                rCell.Value = strAssm
            Next rCell

End Sub

Function 要領チェック(strPart)

    'まず、半角が許されるもの以外は全角に変換する  StrConv(str, vbWide)
        Select Case strPart
            Case 0 To 9:                        '何もしない
            Case Is = ".", "()", "[]", " ":     '何もしない
            Case "a" To "z", "A" To "Z":        '何もしない
            Case Else                           '全角にする
                strPart = StrConv(strPart, vbWide)
        End Select
        
    '禁則文字を削除、変換
        strPart = Replace(strPart, "。", "")
        strPart = Replace(strPart, "、", ",")
        
        要領チェック = strPart
End Function

コードの解説

巡回ループ外郭:対象範囲の各要素を全て巡回

For Each rCell In Selection

For Each記法がようやく身についてきた感じがありますが、
要は対象範囲各要素を全て巡回しろ」です。
今回は選択範囲全セルです。

巡回ループ中身:1文字→束ねる

strAssm = Null
For c = 1 To Len(rCell)
    strPart = Mid(rCell, c, 1)
    strAssm = strAssm & 要領チェック(strPart)
Next c
rCell.Value = strAssm

For c = 1 To Len(rCell)
外郭で選択されたセル1つに対して
1文字ずつループさせる、1層下の外郭宣言です。

strAssm = strAssm & 要領チェック(strPart)
は、後述の自作関数の戻り値を
1つずつお尻にくっつけていく部分です。


関数:1文字ずつ判別・処理

Select Case strPart
    Case 0 To 9:                        '何もしない
    Case Is = ".", "()", "[]", " ":     '何もしない
    Case "a" To "z", "A" To "Z":        '何もしない
    Case Else                           '全角にする
        strPart = StrConv(strPart, vbWide)
End Select

今回は例外を除外するために利用したので
Case Elseで全角にするだけで
前半部分では何の処理もしません。

条件が並行でたくさんある時は
If文ではなくSelect文の方が良いです。

Ifだと構造化するのが面倒だし、
平行だと1つずつ外郭を作らないと行けないので面倒、、、

そして何よりSelect文が素晴らしいのは

  • OR条件の付与がクッソ簡単!
    カンマ区切りで列挙するだけ!)
  • Toで範囲指定の記法もクッソ楽!
    If文だとAND表記しないといけない)


続いて除外後の置換です。

strPart = Replace(strPart, "。", "")
strPart = Replace(strPart, "、", ",")

今回は読点「。」と句点「、」について

  • 読点「。」→削除
  • 句点「、」→「,」

置換しただけです。


最後に要領チェック = strPartで戻り値を返します。
(返し方これで合ってるのかな、、、動くけど)


以上です!
意外とシンプルに書けました!


個人的感想:関数が使えるようになってくるとクソ楽!

わかってからだとこれ以外に言い様がないことなのですが
戻り値を返す必要の有無という謳い文句が
つい最近までサパーリだったのです、、、

「だって'Subプロシージャ'でも共用変数使えば値返してるようなもんじゃん!
Callって付けなきゃだから自作モジュール呼び出してる感が明らかで分かりやすいじゃん!」
と思っていたので、、、

それでももちろん使えるには使えるし、
それが必要なケースもありますが、
関数という字面からも関数名(引数)という構文からも分かるように
入出力関係がわかりやすいんですよね

ああ言えばこう言うやつの仕組みが関数です。


残課題:禁則文字の摘発 (+ぼやき)

禁則文字をSelect文に入れようとしていたのですが、
禁則文字(機種依存文字など)は文字コードを調べなきゃなんですかね?

そこを今回のCase "a" To "z", "A" To "Z":みたいな
範囲指定記法でいけたら良いなと思うですが、
そもそも実務上そこまで面倒見なくていいだろと思ったので割愛しました。

もちろんできるに越したことはないのですが
何でもプログラミングすれば良いってもんじゃないとも思っていて、
それにかける時間と労力に対する費用対効果が微妙だったらやらなくて良いです。


少し脱線しますが、
「そこまで子守りしなきゃダメなの?」
と言いたくなる社内ルールとかホント面倒で、
性善説ベースでのびのびやれる環境づくりこそが働き方改革だと思います。


前職の中小企業だと、
怪我しても会社はほとんどの場合助けてはくれませんでしたが
自由やスピード感、職人芸的な喜びがありました。

今の職場(大企業)は怪我をさせない為の行動制限が凄まじいんです、、、
確かに安全第一だけど、抑圧すら覚えるレベルの制約は
ホント、人という最高のリソースを 生ける屍化してると思います。


とはいえ手駒を増やすためにもぼちぼち調べはしますが、
「こんな簡単な方法あるよー」
みたいなのご存知の方いらっしゃいましたら
ご教授頂けると嬉しいです。

対神エクセル!改行や余計なスペース含むキーワードの検索(非表示セルもヒットするよ)

  1. セルの幅に合わせて改行やスペースでレイアウト調整してるやつ
  2. 非表示セルを含む結合セル

ありませんか?

1.はこーゆーやつ↓


スペース







神  エ  ク  セ  ル  は  死  ね

これ、例えば「エクセル」なんて検索しても
ヒットしないんですよね

キーワードの中に改行コードスペースが挟まってるからです

非表示セルを含む結合セルも
データ数が少ないうちはヒットしますが
いつしかヒットしなくなります、、、

基本的に神エクセル死ねというスタンスですが
理不尽に立ち向かうべく、
スタイリッシュに力業で対処します。


概要

  • 非表示範囲を含む結合セルが相手でもヒットします
  • 改行やスペースなどの余計なものがあってもヒットします
  • 検索結果一覧をユーザーフォームに表示し、
    リストをダブルクリックすると検索結果セルにジャンプします
  • 選択範囲内のみ検索します(全体を検索したければ全選択後にお願いします)
  • 大文字/小文字は完全一致でないとヒットしません

やること

ユーザーフォームの作成

f:id:yoshino-ya:20181019051604p:plain

  1. ユーザーフォームを挿入し、
    モジュール名をUserForm3Findに設定します。
    (モジュール名は何でも良いのですが、標準モジュール上のUserForm名.showの部分と揃えてください)
  2. リストボックスとラベルを挿入し
    リストボックスのオブジェクト名をListBox_検索結果とします。
    (ラベルはあってもなくても良いですがキャプションに補足事項を記入した方が使用時に分かりやすいです。)
  3. あとは下記コードをコピペするだけです
    (どれかオブジェクトをダブルクリックするか
    右クリックメニューからコードの表示(O)を押すかでコードエディタが開きます。)
Private Sub UserForm_Initialize()
        Dim i As Long
        Dim Find結果
        
        For i = 0 To UBound(FindResult)
            ListBox_検索結果.AddItem FindResult(i)
        Next i
End Sub

Private Sub ListBox_検索結果_Click()
    Dim 選択項目アドレス
    
    選択項目アドレス = Split(ListBox_検索結果.Text, "::")
    With Range(選択項目アドレス(0))
        .Select
        .EntireRow.Hidden = False
    End With
End Sub

Private Sub ListBox_検索結果_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Unload Me
End Sub

標準モジュールにコードをコピペする

Public KeyWord As String
Public FindResult() As Variant
Public k As Integer


Sub 文字検索_非表示セルも余計な文字を含むやつもまとめて()
    On Error Resume Next

    Dim KeyWord As String, KW_Arr As Variant
    Dim c As Object, i As Integer
    
    Application.ScreenUpdating = False
    
    KeyWord = InputBox("検索ワードを入力してください")
    k = 0
    
    'キーワードの分解
        For i = 1 To Len(KeyWord)
           SplitKW = SplitKW & "*" & Mid(KeyWord, i, 1)
        Next i
    
    For Each c In Selection
        If c.Value Like "*" & SplitKW & "*" Then
'        If c.Value Like "*" & KeyWord & "*" Then
            ReDim Preserve FindResult(k)
            FindResult(k) = c.Address & "::" & c.Value
            k = k + 1
        End If
    Next c
    
    If k = 0 Then
        MsgBox "検索条件に一致するデータが見つかりません。"
    Else
        UserForm3Find.Show
    End If
    
    Application.ScreenUpdating = True


End Sub

コードの解説

キーワードの分解

自画自賛ですが、この部分、美しくないですか?!

'キーワードの分解
        For i = 1 To Len(KeyWord)
           SplitKW = SplitKW & "*" & Mid(KeyWord, i, 1)
        Next i

For文の外郭を除けば1行で1文字ずつに分解してしまうんです!
(1文字ずつ間に*(ワイルドカード)を挟んでいるだけなのですが)


検索メインループ

    For Each c In Selection
        If c.Value Like "*" & SplitKW & "*" Then
'        If c.Value Like "*" & KeyWord & "*" Then
            ReDim Preserve FindResult(k)
            FindResult(k) = c.Address & "::" & c.Value
            k = k + 1
        End If
    Next c

コメントアウトしてある方(If c.Value Like "*" & KeyWord & "*" Then)を使うと
キーワードを分解しない通常の検索になります。

当初はFindメソッドを使おうとしていたのですが、
Likeでやった方が柔軟だったのでこちらに変更しました。


ユーザーフォーム

Private Sub ListBox_検索結果_Click()
    Dim 選択項目アドレス
    
    選択項目アドレス = Split(ListBox_検索結果.Text, "::")
    With Range(選択項目アドレス(0))
        .Select
        .EntireRow.Hidden = False
    End With
End Sub

検索結果をダブルクリックすると
非表示セルも表示し直した状態で選択状態になります。

本当はクリックする度に
そのセルが選択されるものを目指していたのですが
なんかうまくいきません、、、
(ステップインなら行けるのにな)




以上です。
どうしても社内ルールや古いフォーマット、慣習などから
神エクセルとの対峙が避けられない場合もあると思います。

対神エクセルネタはこれからもやっていこうかなと思います!