okamura – ページ 37 – テックメモ

2020-01-302020-05-05

仕事に必要な文章について

小論文のような文章ではなく、メールや簡単な資料での文章についてメモ。

・パラグラフについて

パラグラフの先頭は字下げしない。
パラグラフごとに空白行を入れる。
パラグラフのサイズは小さくする。数センテンスで1つ。
パラグラフは1つのトピックセンテンスといくつかのサポートセンテンスで作られる。

・センテンスについて

センテンスは短くする。無駄な修飾はしない。

トピックセンテンスはいいたいこと。
トピックセンテンスを先頭にする。

サポートセンテンスはトピックセンテンスの補強。
サポートセンテンスの基本の３種類。

言い換える。　つまり～。
具体例を示す。　例えば～。
予測する。　～だろう。

トピックセンテンスが意見ならサポートセンテンスで理由や実体験に、トピックセンテンスが事実ならサポートセンテンスを意見にしてもいい。

・プロット(パラグラフ構造)について

３段階の構成にする。

何か聞かれている場合
①聞かれたことに対する回答を示す。
②根拠や理由を示す。
③どうすればいいかを示す。

③は立場や知識量によって違う。提案の場合もあれば指示のような場合もある。

提案の場合
①起こっている事実を示す。
②分析を示す。
③どうしたいかを示す。

②か③に理由を入れる。

・実際の書き方

思いついたこと書きたいことを忘れないうちにどんどん書いていって、最後に並べ替える。書きたいことを箇条書きにするのではなく、センテンスとして使える形にまでしておくこと。

・結論

文章は伝わりやすく。内容は空気を読んで必要ならぼかしたりする。

2020-01-262020-01-27

VBA 表からカレンダー形式に変換

前回はJavascript/C#版で今回はVBA版

○○表という感じの帳票を作る場合、行が単位で列が明細というのが一般的。

明細の中に納期や出荷日など日付に関わる情報が入っていることも多く、そこで問題になるのが、この日付情報同士の関係性がパッと把握できないこと。

日付情報がおまけの場合はいいけど、日付情報が重要な場合は把握しやすいフォーマットに変換してみようということで、表からカレンダーに変換する機能を作成してみた。

ループが２重になるので、行数が多い場合は工夫したほうがいいかもしれない。行数が少なければ問題ないと思う。

Sub CreateCalendar()

y = 2020
m = 1

For Each w In Sheets
  If w.Name = "カレンダ" Then
    w.Delete
    Exit For
  End If
Next

Set w = Sheets.Add
w.Name = "カレンダ"

' value

w.Cells(1, 1).Value = y & "年" & m & "月"

w.Cells(2, 1).Value = "日"
w.Cells(2, 2).Value = "月"
w.Cells(2, 3).Value = "火"
w.Cells(2, 4).Value = "水"
w.Cells(2, 5).Value = "木"
w.Cells(2, 6).Value = "金"
w.Cells(2, 7).Value = "土"

startWeekDay = Weekday(DateSerial(y, m, 1)) ' 日1, 月2, 火3, 水4, 木5, 金6, 土7

tmp = DateAdd("m", 1, DateSerial(y, m, 1))
endDay = Day(DateAdd("d", -1, tmp))

counter = 1

For r = 3 To 13 Step 2

  For c = 1 To 7
  
    If (r = 3 And c < startWeekDay) Or (counter > endDay) Then
    
    Else
    
      w.Cells(r, c).Value = counter
      w.Cells(r + 1, c).Value = GetValue(y, m, counter)
      
      counter = counter + 1
    
    End If
    
  Next

Next

' size

w.Columns("A:G").ColumnWidth = 17

w.Rows(1).RowHeight = 24

For Each r In Split("2,3,5,7,9,11,13", ",")
  w.Rows(r).RowHeight = 17
Next

For Each r In Split("4,6,8,10,12,14", ",")
  w.Rows(r).RowHeight = 69
Next

' position

w.Range("A2:G2").HorizontalAlignment = xlCenter

For Each r In Split("3,5,7,9,11,13", ",")
  w.Rows(r).HorizontalAlignment = xlLeft
Next

' border

For Each r In Split("2,3,5,7,9,11,13,15", ",")
  w.Range(w.Cells(CInt(r), 1), w.Cells(CInt(r), 7)).Borders(xlEdgeTop).LineStyle = xlContinuous
Next

For Each c In Split("1,2,3,4,5,6,7,8", ",")
  w.Range(w.Cells(2, CInt(c)), w.Cells(14, CInt(c))).Borders(xlEdgeLeft).LineStyle = xlContinuous
Next

End Sub

Function GetValue(y, m, d)

sheetName = "Sheet1"
matchColumn = 3
valueColumn = 2
startRow = 2
endRow = 11

For r = startRow To endRow

  If DateSerial(y, m, d) = Sheets(sheetName).Cells(r, matchColumn).Value Then
    GetValue = Sheets(sheetName).Cells(r, valueColumn).Value
    Exit Function
  End If

Next

End Function

100

101

102

103

104

105

Sub CreateCalendar()

y = 2020

m = 1

For Each w In Sheets

If w.Name = "カレンダ" Then

w.Delete

Exit For

End If

Set w = Sheets.Add

w.Name = "カレンダ"

' value

w.Cells(1, 1).Value = y & "年" & m & "月"

w.Cells(2, 1).Value = "日"

w.Cells(2, 2).Value = "月"

w.Cells(2, 3).Value = "火"

w.Cells(2, 4).Value = "水"

w.Cells(2, 5).Value = "木"

w.Cells(2, 6).Value = "金"

w.Cells(2, 7).Value = "土"

startWeekDay = Weekday(DateSerial(y, m, 1)) ' 日1, 月2, 火3, 水4, 木5, 金6, 土7

tmp = DateAdd("m", 1, DateSerial(y, m, 1))

endDay = Day(DateAdd("d", -1, tmp))

counter = 1

For r = 3 To 13 Step 2

For c = 1 To 7

If (r = 3 And c < startWeekDay) Or (counter > endDay) Then

Else

w.Cells(r, c).Value = counter

w.Cells(r + 1, c).Value = GetValue(y, m, counter)

counter = counter + 1

End If

' size

w.Columns("A:G").ColumnWidth = 17

w.Rows(1).RowHeight = 24

For Each r In Split("2,3,5,7,9,11,13", ",")

w.Rows(r).RowHeight = 17

For Each r In Split("4,6,8,10,12,14", ",")

w.Rows(r).RowHeight = 69

' position

w.Range("A2:G2").HorizontalAlignment = xlCenter

For Each r In Split("3,5,7,9,11,13", ",")

w.Rows(r).HorizontalAlignment = xlLeft

' border

For Each r In Split("2,3,5,7,9,11,13,15", ",")

w.Range(w.Cells(CInt(r), 1), w.Cells(CInt(r), 7)).Borders(xlEdgeTop).LineStyle = xlContinuous

For Each c In Split("1,2,3,4,5,6,7,8", ",")

w.Range(w.Cells(2, CInt(c)), w.Cells(14, CInt(c))).Borders(xlEdgeLeft).LineStyle = xlContinuous

End Sub

Function GetValue(y, m, d)

sheetName = "Sheet1"

matchColumn = 3

valueColumn = 2

startRow = 2

endRow = 11

For r = startRow To endRow

If DateSerial(y, m, d) = Sheets(sheetName).Cells(r, matchColumn).Value Then

GetValue = Sheets(sheetName).Cells(r, valueColumn).Value

Exit Function

End If

End Function

2020-01-242020-01-27

Javascript/C# 手作りカレンダー

一般的にカレンダーを自作する必要性はないと思うけど、作る必要がでてきたのでとりあえずメモ。

<!doctype html>
<html lang="ja">
<head>
<meta charset="utf-8" />
</head>
<body>
<script>

let year = '2020';
let month = '1';

let html = '<table>';

html += '<tr>';
let week = ['日', '月', '火', '水', '木', '金', '土'];
for (let col = 0; col < week.length; col++) {
    html += '<td>' + week[col] + '</td>';
}
html += '</tr>';

let startWeekDay = new Date(year, month - 1, 1).getDay();
let endDay = new Date(year, month,  0).getDate();
let counter = 1;

// startWeekDay: 日0, 月1, 火2, 水3, 木4, 金5, 土6
// endDay: 最終日
// counter: 書込日付

// 縦6(0～5), 横7(0～6)のループ

for (let row = 0; row < 6; row++) {

    html += '<tr>';
    for (let col = 0; col < 7; col++) {

        if ((row == 0 && col < startWeekDay) || (counter > endDay)) {

            // 第1週と最終週の判定
            // 第1週: colが増えていき、startWeekDay以上の場合は日付が書き込まれる
            // 最終週: counterが増えていき、endDay以上になると空白

            html += '<td></td>';
        } else {
            html += '<td>' + counter + '</td>';
            counter++;
        }
    }
    html += '</tr>';
}
html += '</table>';

document.body.innerHTML = html;

</script>
</body>
</html>

<!doctype html>

<head>

</head>

<body>

let year = '2020';

let month = '1';

let html = '<table>';

html += '<tr>';

let week = ['日', '月', '火', '水', '木', '金', '土'];

for (let col = 0; col < week.length; col++) {

html += '<td>' + week[col] + '</td>';

}

html += '</tr>';

let startWeekDay = new Date(year, month - 1, 1).getDay();

let endDay = new Date(year, month, 0).getDate();

let counter = 1;

// startWeekDay: 日0, 月1, 火2, 水3, 木4, 金5, 土6

// endDay: 最終日

// counter: 書込日付

// 縦6(0～5), 横7(0～6)のループ

for (let row = 0; row < 6; row++) {

html += '<tr>';

for (let col = 0; col < 7; col++) {

if ((row == 0 && col < startWeekDay) || (counter > endDay)) {

// 第1週と最終週の判定

// 第1週: colが増えていき、startWeekDay以上の場合は日付が書き込まれる

// 最終週: counterが増えていき、endDay以上になると空白

html += '<td></td>';

} else {

html += '<td>' + counter + '</td>';

counter++;

}

html += '</tr>';

}

html += '</table>';

document.body.innerHTML = html;

</script>

</body>

</html>

C#(DataGridView)版

using System;
using System.Collections.Generic;
using System.Windows.Forms;

namespace CreateCalendar
{
    public partial class Form1 : Form
    {
        public Form1()
        {
            InitializeComponent();

            dataGridView1.AllowUserToAddRows = false;
            dataGridView1.DefaultCellStyle.WrapMode = DataGridViewTriState.True;

            List<DataGridViewTextBoxColumn> columns = new List<DataGridViewTextBoxColumn>();

            foreach(var s in new string[] { "日", "月", "火", "水", "木", "金", "土" })
            {
                columns.Add(new DataGridViewTextBoxColumn()
                {
                    HeaderText = s,
                    Width = 120,
                    SortMode = DataGridViewColumnSortMode.NotSortable
                });
            }

            dataGridView1.Columns.AddRange(columns.ToArray());

            int y = 2019;
            int m = 12;

            int startWeekDay = (int)new DateTime(y, m, 1).DayOfWeek; // 日=0, 月=1, 火=2, 水=3, 木=4, 金=5, 土=6
            int endDay = new DateTime(y, m, 1).AddMonths(1).AddDays(-1).Day;
            int counter = 1;

            for (int r = 0; r < 12; r++)
            {
                dataGridView1.Rows.Add();

                if (r % 2 == 0)
                {
                    dataGridView1.Rows[r].Height = 18;
                }
                else
                {
                    dataGridView1.Rows[r].Height = 80;
                }
            }

            for (int r = 0; r < 12; r = r + 2)
            {
                for (int c = 0; c < 7; c++)
                {
                    if ((r == 0 && c < startWeekDay) || counter > endDay)
                    {
                        dataGridView1.Rows[r].Cells[c].Value = "";
                    }
                    else
                    {
                        dataGridView1.Rows[r].Cells[c].Value = counter.ToString();
                        dataGridView1.Rows[r + 1].Cells[c].Value = "";

                        counter++;
                    }
                }
            }
        }
    }
}

using System;

using System.Collections.Generic;

using System.Windows.Forms;

namespace CreateCalendar

{

public partial class Form1 : Form

{

public Form1()

{

InitializeComponent();

dataGridView1.AllowUserToAddRows = false;

dataGridView1.DefaultCellStyle.WrapMode = DataGridViewTriState.True;

List<DataGridViewTextBoxColumn> columns = new List<DataGridViewTextBoxColumn>();

foreach(var s in new string[] { "日", "月", "火", "水", "木", "金", "土" })

{

columns.Add(new DataGridViewTextBoxColumn()

{

HeaderText = s,

Width = 120,

SortMode = DataGridViewColumnSortMode.NotSortable

});

}

dataGridView1.Columns.AddRange(columns.ToArray());

int y = 2019;

int m = 12;

int startWeekDay = (int)new DateTime(y, m, 1).DayOfWeek; // 日=0, 月=1, 火=2, 水=3, 木=4, 金=5, 土=6

int endDay = new DateTime(y, m, 1).AddMonths(1).AddDays(-1).Day;

int counter = 1;

for (int r = 0; r < 12; r++)

{

dataGridView1.Rows.Add();

if (r % 2 == 0)

{

dataGridView1.Rows[r].Height = 18;

}

else

{

dataGridView1.Rows[r].Height = 80;

}

for (int r = 0; r < 12; r = r + 2)

{

for (int c = 0; c < 7; c++)

{

if ((r == 0 && c < startWeekDay) || counter > endDay)

{

dataGridView1.Rows[r].Cells[c].Value = "";

}

else

{

dataGridView1.Rows[r].Cells[c].Value = counter.ToString();

dataGridView1.Rows[r + 1].Cells[c].Value = "";

counter++;

}

2020-01-212020-01-22

VBA 講座ワークシート関数を挿入

以前書いたエクセルVBA講座の続きです。

VBA 講座

今回は少し実用的なものとしてループでワークシート関数を挿入する方法をお伝えしたいと思います。

ワークシート関数だからといって挿入自体に特別な方法は必要ありません。そのまま文字として入力すれば大丈夫です。

Sheets("Sheet1").Cells(1, 1).Value = "=SUM(A2:A3)"

1	Sheets("Sheet1").Cells(1, 1).Value = "=SUM(A2:A3)"

これを実行すると、Sheet1というシートのA1セルにSUM関数が入ります。

ではもう少し便利にするためにForループのカウンター変数を利用してみます。

For r = 1 To 4
Sheets("Sheet1").Cells(r, 1).Value = "=SUM(B" & r & ":C" & r & ")"
Next

For r = 1 To 4

Sheets("Sheet1").Cells(r, 1).Value = "=SUM(B" & r & ":C" & r & ")"

細かく見ていきます。

先ずForループの中の処理は4回実行されます。そのときrというカウンタ変数は1,2,3,4というように変化していきます。

rの変化と指定しているセルの位置を考えてみると、
rが1のときCells(1,2)
rが2のときCells(2,2)
rが3のときCells(3,2)
rが4のときCells(4,2)
となります。Cellsの中身は行,列ですので、A1,A2,A3,A4セルを対象にして挿入していることが分かります。

“=SUM(B” & r & “:C” & r & “)”の部分について、文字としてそのまま利用したい部分はダブルクォーテーションで囲い、変数の中身を利用したい部分はダブルクォーテーションで囲わずそのまま記入します。それらを＆記号(左右に半角スペース必須)でつなぎます。

＊＊＊

この部分は分かりづらいのもう少し細かく解説すると、セルの中に書き込める値は２種類(実際はもっとありますが現時点では)あると考えてください。１つはダブルクォーテーションで囲った文字、もう１つは変数で、ダブルクォーテーションで囲った文字はそのまま書き込まれ、変数は中身が利用されます。

そしてその２種類は＆記号(左右に半角スペース必須)で、順番や数に制限なく自由につなぐことができます。

v1 = "hello"
v2 = "world"

MsgBox v1 & " " & v2

v1 = "hello"

v2 = "world"

MsgBox v1 & " " & v2

v1 = "hello"
v2 = " "
v3 = "world"

MsgBox v1 & v2 & v3

v1 = "hello"

v2 = " "

v3 = "world"

MsgBox v1 & v2 & v3

どちらも実行するとhello worldと表示されます。

＊＊＊

話を戻します。

具体的にrの変化を見ていくと、
rが1のとき、”=SUM(B1:C1)”
rが2のとき、”=SUM(B2:C2)”
rが3のとき、”=SUM(B3:C3)”
rが4のとき、”=SUM(B4:C4)”
となります。

結果として
rが1のとき、A1セルに”=SUM(B1:C1)”
rが2のとき、A2セルに”=SUM(B2:C2)”
rが3のとき、A3セルに”=SUM(B3:C3)”
rが4のとき、A4セルに”=SUM(B4:C4)”
が入るということになります。

Forループのカウンタ変数をループの中で利用することはよくあります。むしろループの中で固定の文字列を挿入することの方が少ないぐらいです。

さらにカウンタ変数を利用したワークシート関数を挿入する方法が使えるようになると、かなり複雑なことができるようになります。

2020-01-142020-05-10

VBA SQL実験用④(SQLite)

最近では専門家ではなくてもデータ分析ができたほうがいいという話をよく聞きます。そういう話の中で利用されているソフトはだいたい専用ソフトかエクセルといった感じでしょうか。

ただ数は少ないですがSQLを使おうというのもあるようです。実際SQLは非常に便利でエクセルより多少敷居は高いですが、少し使えればエクセルでは面倒な処理も簡単にできたりします。経験上、ワークシート関数、VBA、SQLを使い分ければほとんどの処理ができると思います。

ですが、いざSQLを使おうとするとどのソフトを使ったらいいのか迷うと思います。一般的にはAccess、SQL Server、MySQL(MariaDB)、SQLiteあたりがお勧めされていますが、もしPCにAccessが入っているならAccessが一番手軽に始められるのではないかと思います。今回はSQLiteを採用していますが、私も最初はAccessを使っていました。

中小企業で働いているとデータ分析やITの専門家がいない場合も多いので、自分たちで少しでもデータ分析ができると役に立つことが多いです。

Sub auto_open()

Application.CommandBars("cell").Reset

With Application.CommandBars("cell").Controls.Add
.OnAction = "CreateTable"
.Caption = "テーブル作成"
End With

With Application.CommandBars("cell").Controls.Add
.OnAction = "QuerySelect"
.Caption = "SQL実行"
End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2
  Application.CommandBars("cell").Controls("テーブル作成").Delete
  Application.CommandBars("cell").Controls("SQL実行").Delete
Next i

End Sub

Function GetCon()

GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & ThisWorkbook.Path & "\dat"

End Function

Function GetType(s)

'型はSQLite以外の互換性のため

Select Case s
  Case "s"
  tmp = "varchar(255)"
  Case "i"
  tmp = "bigint"
  Case "m"
  tmp = "money"
  Case "d"
  tmp = "datetime"
End Select

GetType = tmp

End Function

Sub CreateTable()

Set cn = CreateObject("adodb.connection")
cn.Open GetCon

tbl = InputBox("テーブル名")
If tbl = "" Then Exit Sub

'テーブル削除

On Error Resume Next
cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

  tmp = GetType(Right(ActiveSheet.Cells(Selection(1).Row, c).Value, 1))
  fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & " " & tmp & ","

Next c

fld = Left(fld, Len(fld) - 1)

q = "create table " & tbl & " (id integer primary key," & fld & ")"
cn.Execute q: Debug.Print q

'データ登録

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column
  fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & ","
Next c

fld = Left(fld, Len(fld) - 1)

For r = (Selection(1).Row) + 1 To Selection(Selection.Count).Row
  For cc = Selection(1).Column To Selection(Selection.Count).Column
    rec = rec & "'" & ActiveSheet.Cells(r, cc).Value & "'" & ","
  Next cc

  rec = Left(rec, Len(rec) - 1)
  
  q = "insert into " & tbl & " (" & fld & ") values (" & rec & ")"
  cn.Execute q: Debug.Print q

  rec = ""
Next r

If cn.State = 1 Then cn.Close
Set cn = Nothing

MsgBox "done"

End Sub

Sub ExecuteQuery(q)

Set cn = CreateObject("adodb.connection")
Set rn = CreateObject("adodb.recordset")

cn.Open GetCon
rn.Open q, cn

'フィールド作成

i = 0

For c = Selection(1).Column To (Selection(1).Column + rn.Fields.Count) - 1
  Cells(Selection(Selection.Count).Row + 1, c).Value = rn.Fields(i).Name
  i = i + 1
Next c

'データ読込

Cells(Selection(Selection.Count).Row + 2, Selection(1).Column).CopyFromRecordset rn

If rn.State = 1 Then rn.Close
Set rn = Nothing

If cn.State = 1 Then cn.Close
Set cn = Nothing

End Sub

Sub ExecuteNonQuery(q)

Set cn = CreateObject("adodb.connection")

cn.Open GetCon
cn.Execute q

If cn.State = 1 Then cn.Close
Set cn = Nothing

End Sub

Sub QuerySelect()

If Selection.Rows.Count = 1 Then
  q = ActiveCell.Value
Else
  For r = 1 To Selection.Rows.Count
    q = q & " " & Selection(r)
  Next r
End If

If Left(q, 1) = "s" Then
  ExecuteQuery (q)
Else
  ExecuteNonQuery (q)
End If

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

Sub auto_open()

Application.CommandBars("cell").Reset

With Application.CommandBars("cell").Controls.Add

.OnAction = "CreateTable"

.Caption = "テーブル作成"

End With

With Application.CommandBars("cell").Controls.Add

.OnAction = "QuerySelect"

.Caption = "SQL実行"

End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2

Application.CommandBars("cell").Controls("テーブル作成").Delete

Application.CommandBars("cell").Controls("SQL実行").Delete

Next i

End Sub

Function GetCon()

GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & ThisWorkbook.Path & "\dat"

End Function

Function GetType(s)

'型はSQLite以外の互換性のため

Select Case s

Case "s"

tmp = "varchar(255)"

Case "i"

tmp = "bigint"

Case "m"

tmp = "money"

Case "d"

tmp = "datetime"

End Select

GetType = tmp

End Function

Sub CreateTable()

Set cn = CreateObject("adodb.connection")

cn.Open GetCon

tbl = InputBox("テーブル名")

If tbl = "" Then Exit Sub

'テーブル削除

On Error Resume Next

cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

tmp = GetType(Right(ActiveSheet.Cells(Selection(1).Row, c).Value, 1))

fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & " " & tmp & ","

Next c

fld = Left(fld, Len(fld) - 1)

q = "create table " & tbl & " (id integer primary key," & fld & ")"

cn.Execute q: Debug.Print q

'データ登録

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & ","

Next c

fld = Left(fld, Len(fld) - 1)

For r = (Selection(1).Row) + 1 To Selection(Selection.Count).Row

For cc = Selection(1).Column To Selection(Selection.Count).Column

rec = rec & "'" & ActiveSheet.Cells(r, cc).Value & "'" & ","

Next cc

rec = Left(rec, Len(rec) - 1)

q = "insert into " & tbl & " (" & fld & ") values (" & rec & ")"

cn.Execute q: Debug.Print q

rec = ""

Next r

If cn.State = 1 Then cn.Close

Set cn = Nothing

MsgBox "done"

End Sub

Sub ExecuteQuery(q)

Set cn = CreateObject("adodb.connection")

Set rn = CreateObject("adodb.recordset")

cn.Open GetCon

rn.Open q, cn

'フィールド作成

i = 0

For c = Selection(1).Column To (Selection(1).Column + rn.Fields.Count) - 1

Cells(Selection(Selection.Count).Row + 1, c).Value = rn.Fields(i).Name

i = i + 1

Next c

'データ読込

Cells(Selection(Selection.Count).Row + 2, Selection(1).Column).CopyFromRecordset rn

If rn.State = 1 Then rn.Close

Set rn = Nothing

If cn.State = 1 Then cn.Close

Set cn = Nothing

End Sub

Sub ExecuteNonQuery(q)

Set cn = CreateObject("adodb.connection")

cn.Open GetCon

cn.Execute q

If cn.State = 1 Then cn.Close

Set cn = Nothing

End Sub

Sub QuerySelect()

If Selection.Rows.Count = 1 Then

q = ActiveCell.Value

Else

For r = 1 To Selection.Rows.Count

q = q & " " & Selection(r)

Next r

End If

If Left(q, 1) = "s" Then

ExecuteQuery (q)

Else

ExecuteNonQuery (q)

End If

End Sub

追記

ちょっと原因は分からないけど、SQLite標準のカラムのデータ型(textやinteger)でテーブルを作成するとCopyFromRecordsetで取得できなくなる。

varchar(255)をカラムのデータ型に指定しているとCopyFromRecordsetで問題なく取得できる。

CopyFromRecordsetはテーブル作成時の型の影響を受けているらしい。とりあえずCopyFromRecordsetを使わないパターン

Sub auto_open()

Application.CommandBars("cell").Reset

With Application.CommandBars("cell").Controls.Add
.OnAction = "CreateTable"
.Caption = "テーブル作成"
End With

With Application.CommandBars("cell").Controls.Add
.OnAction = "QuerySelect"
.Caption = "SQL実行"
End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2
  Application.CommandBars("cell").Controls("テーブル作成").Delete
  Application.CommandBars("cell").Controls("SQL実行").Delete
Next i

End Sub

Function GetCon()

'GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & ThisWorkbook.Path & "\dat"
GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & Sheets("設定").Cells(1, 2).Value

End Function

Function GetType(s)

Select Case s
  Case "s"
  tmp = "text"
  Case "i"
  tmp = "integer"
End Select

GetType = tmp

End Function

Sub CreateTable()

Set cn = CreateObject("adodb.connection")
cn.Open GetCon

tbl = InputBox("テーブル名")
If tbl = "" Then Exit Sub

'テーブル削除

On Error Resume Next
cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0

Set topLeft = Selection(1)
Set bottomRight = Selection(Selection.Count)

head = ""
For c = topLeft.Column To bottomRight.Column
  tmp = GetType(Right(ActiveSheet.Cells(topLeft.Row, c).Value, 1))
  head = head & ActiveSheet.Cells(topLeft.Row, c).Value & " " & tmp & ","
Next c

head = Left(head, Len(head) - 1)

q = "create table " & tbl & " (id integer primary key," & head & ")"
cn.Execute q

'データ登録

head = ""
For c = topLeft.Column To bottomRight.Column
  head = head & ActiveSheet.Cells(topLeft.Row, c).Value & ","
Next c

head = Left(head, Len(head) - 1)
For r = topLeft.Row + 1 To bottomRight.Row

  For c = topLeft.Column To bottomRight.Column
    body = body & "'" & ActiveSheet.Cells(r, c).Value & "'" & ","
  Next c

  body = Left(body, Len(body) - 1)
  
  q = "insert into " & tbl & " (" & head & ") values (" & body & ")"
  cn.Execute q

  body = ""
  
Next r

If cn.State = 1 Then cn.Close
Set cn = Nothing

MsgBox "done"

End Sub

Sub ExecuteQuery(q)

Set cn = CreateObject("adodb.connection")
Set rn = CreateObject("adodb.recordset")

cn.Open GetCon
rn.Open q, cn

Set topLeft = Selection(1)
Set bottomRight = Selection(Selection.Count)

'見出

i = 0
For c = topLeft.Column To (topLeft.Column + rn.Fields.Count) - 1
  ActiveSheet.Cells(bottomRight.Row + 1, c).Value = rn.Fields(i).Name
  i = i + 1
Next c

'本体

r = 2
Do Until rn.EOF

  i = 0
  For c = topLeft.Column To (topLeft.Column + rn.Fields.Count) - 1
    ActiveSheet.Cells(bottomRight.Row + r, c).Value = rn.Fields(i)
    i = i + 1
  Next c
  
  rn.MoveNext
  r = r + 1
Loop

If rn.State = 1 Then rn.Close
Set rn = Nothing

If cn.State = 1 Then cn.Close
Set cn = Nothing

End Sub

Sub ExecuteNonQuery(q)

Set cn = CreateObject("adodb.connection")

cn.Open GetCon
cn.Execute q

If cn.State = 1 Then cn.Close
Set cn = Nothing

End Sub

Sub QuerySelect()

If Selection.Rows.Count = 1 Then
  q = ActiveCell.Value
Else
  For r = 1 To Selection.Rows.Count
    q = q & " " & Selection(r)
  Next r
End If

If Left(q, 1) = "s" Then
  ExecuteQuery (q)
Else
  ExecuteNonQuery (q)
End If

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

Sub auto_open()

Application.CommandBars("cell").Reset

With Application.CommandBars("cell").Controls.Add

.OnAction = "CreateTable"

.Caption = "テーブル作成"

End With

With Application.CommandBars("cell").Controls.Add

.OnAction = "QuerySelect"

.Caption = "SQL実行"

End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2

Application.CommandBars("cell").Controls("テーブル作成").Delete

Application.CommandBars("cell").Controls("SQL実行").Delete

Next i

End Sub

Function GetCon()

'GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & ThisWorkbook.Path & "\dat"

GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & Sheets("設定").Cells(1, 2).Value

End Function

Function GetType(s)

Select Case s

Case "s"

tmp = "text"

Case "i"

tmp = "integer"

End Select

GetType = tmp

End Function

Sub CreateTable()

Set cn = CreateObject("adodb.connection")

cn.Open GetCon

tbl = InputBox("テーブル名")

If tbl = "" Then Exit Sub

'テーブル削除

On Error Resume Next

cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0

Set topLeft = Selection(1)

Set bottomRight = Selection(Selection.Count)

head = ""

For c = topLeft.Column To bottomRight.Column

tmp = GetType(Right(ActiveSheet.Cells(topLeft.Row, c).Value, 1))

head = head & ActiveSheet.Cells(topLeft.Row, c).Value & " " & tmp & ","

Next c

head = Left(head, Len(head) - 1)

q = "create table " & tbl & " (id integer primary key," & head & ")"

cn.Execute q

'データ登録

head = ""

For c = topLeft.Column To bottomRight.Column

head = head & ActiveSheet.Cells(topLeft.Row, c).Value & ","

Next c

head = Left(head, Len(head) - 1)

For r = topLeft.Row + 1 To bottomRight.Row

For c = topLeft.Column To bottomRight.Column

body = body & "'" & ActiveSheet.Cells(r, c).Value & "'" & ","

Next c

body = Left(body, Len(body) - 1)

q = "insert into " & tbl & " (" & head & ") values (" & body & ")"

cn.Execute q

body = ""

Next r

If cn.State = 1 Then cn.Close

Set cn = Nothing

MsgBox "done"

End Sub

Sub ExecuteQuery(q)

Set cn = CreateObject("adodb.connection")

Set rn = CreateObject("adodb.recordset")

cn.Open GetCon

rn.Open q, cn

Set topLeft = Selection(1)

Set bottomRight = Selection(Selection.Count)

'見出

i = 0

For c = topLeft.Column To (topLeft.Column + rn.Fields.Count) - 1

ActiveSheet.Cells(bottomRight.Row + 1, c).Value = rn.Fields(i).Name

i = i + 1

Next c

'本体

r = 2

Do Until rn.EOF

i = 0

For c = topLeft.Column To (topLeft.Column + rn.Fields.Count) - 1

ActiveSheet.Cells(bottomRight.Row + r, c).Value = rn.Fields(i)

i = i + 1

Next c

rn.MoveNext

r = r + 1

Loop

If rn.State = 1 Then rn.Close

Set rn = Nothing

If cn.State = 1 Then cn.Close

Set cn = Nothing

End Sub

Sub ExecuteNonQuery(q)

Set cn = CreateObject("adodb.connection")

cn.Open GetCon

cn.Execute q

If cn.State = 1 Then cn.Close

Set cn = Nothing

End Sub

Sub QuerySelect()

If Selection.Rows.Count = 1 Then

q = ActiveCell.Value

Else

For r = 1 To Selection.Rows.Count

q = q & " " & Selection(r)

Next r

End If

If Left(q, 1) = "s" Then

ExecuteQuery (q)

Else

ExecuteNonQuery (q)

End If

End Sub

2020-01-132020-05-06

Excel 仕入集計(簡易原価計算)

原価計算といえば製造業では特に重視されていてよく耳にするかと思います。一応、会計的に正しい計算法というのもあるのですが、中小企業ではカスタマイズしたルールを用いてエクセルでざっくり計算していることが多いように思います。

今回は、本格的な原価計算とまではいかないけど、仕入をエクセルで集計するためには、どのように入力していけばいいのか少し考えてみたいと思います。

・集計単位で番号を付加する

製造番号やシリアル番号など名称に違いはあっても、恐らくどの会社でも管理用の番号を付加していると思います。受注単位、製造単位、単品ごとなど付加する単位は会社によって違うと思いますが、重要なのは原価を求めたい単位で番号を付加することです。例えば、受注はA製品×2台で受注番号を付加しているが、原価集計したいのはA製品それぞれ1台という場合、受注番号とは別に番号が必要になるということです。

一般的にはこういう場合、枝番で単品ごとの単位にしていることが多いと思います。そこでよくあるのが枝番を無視する工程の存在です。無視している工程では原価集計ができなくなるので注意が必要です。

ここではA製品×2台に対して001というNoを割り振ったとします。

・原価発生時エクセルに入力

まず原価として集計したいものは全てエクセルに入力することとします。会社によっては販管費相当でも個別の原価に入れたりしていると思います。例えば、運送費を個別の原価に入れて集計したい場合、運送費も入力するということです。

・仕入入力について

買掛単位ではなく原価単位の行数で入力します。

例えば、A製品(No001)とB製品に使う材料を購入したら1行の明細で100円となった場合。2行に分けてA用に50円、B用に50円というように入力します。会計では買掛単位として扱うことが多いと思うので、必要であればそれぞれ別管理が必要になるかもしれません。

仕入が1行でも、計算するタイミングで何かしらの基準でA製品とB製品に対して按分して計算するばいいのでは？と思われるかもしれません。もちろん専用ソフトでしっかり管理されていれば可能ですが、そうでないなら、最初から明細を原価単位で入力しておくほうが楽だと思います。

・エクセルの作り方

今回は入力、単価マスタ、集計結果を作っています。実際はそれぞれ別シートにして項目も多くなるかと思います。

ポイントとなる関数はSUMIFS、VLOOKUP、INDIRECTです。関数自体は他のサイトに分かりやすい解説があるのでそちらを見ていただくとして、どのように使っているのかというと、入力から単価マスタの参照はVLOOKUPを使い、集計結果から入力の参照はSUMIFSを使い、それぞれ最終行をINDIRECTで指定しています。

この中でも一番重要なのがSUMIFSです。単価マスタはなくても大丈夫なので、もっと簡単にしたい場合は入力と集計結果だけ作って、SUMIFSで集計しても大丈夫かと思います。

2020-01-042020-01-13

VBA 講座

エクセルにはVBAという開発環境が付属しており、VBAを活用するとエクセル上の作業を自動化したりすることができます。

大手企業では業務ごとに専用ソフトを導入していたり、開発の専門部署があったりしますので、一般の従業員がVBAを使う機会は少ないかもしれませんが、中小企業ではVBAを使うと業務を効率化することができます。

私もそれほど詳しくありませんが、実際に今までいくつかVBAを業務に役立ててきましたので、ここではその経験を分かりやすくお伝えしていきたいと思います。

VBAを始めるにあたって何が大変なのかというと、面白くもない基礎知識を覚えなければいけないということがあります。VBAはプログラミング言語の一種なので、プログラミング未経験の人からすると、最初に覚えなければいけない内容もかなりの量になってしまいます。

やりたいことは明確なのに、すぐにそこに行けないのはもどかしいものです。ですので、ここではなるべく早く使えるようになることを目標にして、細かい部分は省き、必要なことは作りながら覚えればいいという考えで進めたいと思います。

また、VBAなどプログラミングではやりたいことに対して複数の方法が存在するのですが、これもあえて一つの方法を採用してしまおうかと思います。

VBAの実行方法

開発タブ＞挿入＞ActiveXコントロール＞コマンドボタン
追加されたコマンドボタンをダブルクリックします。

VBA用のエディタが表示されたと思います。

表示された
Private Sub CommandButton1_Click()
と
End Sub
の間に処理を記入していくことになります。

もし開発タブが表示されていない場合は、
ファイル＞オプション＞リボンのユーザー設定
開発にチェックを付けます。

ではどうやってVBAを実行するのか？ですが、開発タブの中にデザインモードというボタンがあり、これが押されている状態では今のようにVBAのエディタが開きます。

デザインモードのボタンをもう一度押すと、デザインモードが押されていない状態になり、その状態でコマンドボタンを押すとVBAが実行されます。

開発中にわざわざボタンを押さずに、素早く実行したい場合は、
Private Sub CommandButton1_Click()
と
End Sub
の間にカーソルがある状態で、VBA用エディタの再生ボタンを押すことで実行できます。

セルに値を入れる

Sheets(“Sheet1”).Cells(1, 1).Value = “1”

セルに値を入れるときはこのように書きます。どのシートなのか、どのセルなのかを指定し、そのセルの中身をValueで指定します。

ちなみ、セルを指定しているのだからわざわざValueは必要ないのでは？と思うかもしれません。(実際なくても動くのですが)なぜValueが必要なのかというと、セルの塗りつぶしなどセルの中身とは関係ない部分を指定することもあるので、中身はValueで操作できるよと覚えておいてください。

細かくみていくと、
Sheets(“シート名”)
でシート名を指定し、
Cells(行, 列)
で何行目の何列目にあるセルなのかを指定し、
Value
で指定したセルの値を操作できるという意味です。

ここでのイコールは代入(入れる)という意味です。つまりSheet1の1行目で1列目のセルに”1″を入れるという意味です。

数値と文字

VBAでは数値だったらそのまま直接(1など)書くことができます。文字だったらダブルクォーテーションで囲う(“1″など)必要があります。でも今回1をダブルクォーテーションで囲ってなかった？と思うかもしれません。

少し難しい話ですが、1と”1″は一般的なプログラミングでは数値の1と文字の1として区別されます。いくつか違いはありますが、数値の1は四則演算できて、文字の1は四則演算できないというような違いがあります。つまり上記では数値ではなく文字の1を代入したということです。

VBAの特徴として、文字の数値(“1″など)でも、どうやら数値として使ってるっぽいなとVBAが判断すると自動で数値として扱ってくれます。

このあたりを正確に理解しようとすると型というものが出てきてしまうので、今は数値と文字の違いはあるけど、VBAはいい具合に判断してくれる程度に理解しておけば大丈夫です。

値のコピー

セルの書式や文字色などもコピーできるのですが、最初は値だけコピーする方法を覚えておけば大丈夫です。Valueを使ってイコールで代入するだけです。

Sheets("Sheet1").Cells(1, 1).Value = Sheets("Sheet1").Cells(2, 2).Value

1	Sheets("Sheet1").Cells(1, 1).Value = Sheets("Sheet1").Cells(2, 2).Value

値の表示(MsgBox)

次はセルの値を表示してみます。

MsgBox Sheets(“Sheet1”).Cells(1, 1).Value

代入ではないのでイコールはありません。代わりにMsgBoxと書かれています。これで指定した値をダイアログで表示することができます。Sheet1の1行目1列目のセルの値が表示されます。

ちなみに
MsgBox “A”
などのように表示する値を直接指定することも可能です。

MsgBoxはデバッグとしても利用されます。例えばプログラムを作っている最中に変数の中身を確認したい場合など頻繁にMsgBoxは利用されます。

v = "1"
MsgBox v
v = "2"
MsgBox v

v = "1"

MsgBox v

v = "2"

MsgBox v

ループ(For文)

セルの値を１つずつ設定したり取得したりするだけでは手作業と大きな違いはありません。VBAのメリットは多くの処理を自動化できることですが、ループは自動化の基本の一つです。

For i = 1 To 10
Sheets("Sheet1").Cells(i, 1).Value = i
Next

For i = 1 To 10

Sheets("Sheet1").Cells(i, 1).Value = i

これを実行するとA列の1～10行目に1～10の値が入ります。

For 変数 = 開始値 to 終了値
　処理
Next

というのが基本です。

現時点では変数というのは入れ物と理解しておけば大丈夫です。名前も自由につけることができ、ここではiとしていますが、counterなどとしても大丈夫です。

変数iには1から10まで順番に代入され、そのたびに処理が実行されるということです。具体的にいうと
変数iが1のとき、
Sheets(“Sheet1”).Cells(1, 1).Value = 1
として処理されます。
変数iが2のとき、
Sheets(“Sheet1”).Cells(2, 1).Value = 2
として処理されます。
このように、iが10になるまで繰り返されていきます。

また、変数は1からの必要はありませんし、処理の中で使わなくても問題ありません。

For i = 2 To 3
MsgBox "A"
Next

For i = 2 To 3

MsgBox "A"

これだとAが2回表示されるだけです。処理でiは使っていません。ループを2回するだけです。

条件

次に説明するDo-WhileとIfで条件というのがでてきます。条件とは2つの変数あるいは直接の値を指定し、その2つの間に下記の式を書いてそれが満たされた場合、True(処理の実行)となり、満たされない場合、False(処理が実行されない)となります。

条件は
A = B (AとBが同じ)
A <> B (AとBが違う)
A >= B (AがB以上)
A <= B (AがB以下)
A > B (AがBより大きい)
A < B (AがBより小さい)
のような種類があります。

実際AとBには変数か値が入ります。
変数　条件　変数
変数　条件　　値
　値　条件　変数
　値　条件　　値
いずれの組み合わせてでも大丈夫です。

条件はOrとAndを使うことで複数同時に使うこともできます。意味はそのまま、Orであればどちらかの条件を満たす、Andであれば両方の条件を満たすという意味になります。

例えば
c = 5 Or r = 5
であれば、cという変数の中に5が入っている状態か、rという変数の中に5が入っている状態のどちらか一方でTrueとなります。

c = 5 And r = 5
であれば、cという変数の中に5が入っている状態であり、rという変数の中にも5が入っている状態ではじめてTrueとなります。

ループ(Do-While文)

Do While 条件
　処理
Loop
が基本です。

条件が満たされている間処理をします。

i = 1
Do While i <= 3
  MsgBox i
  i = i + 1
Loop

i = 1

Do While i <= 3

MsgBox i

i = i + 1

Loop

これで1から3まで表示されます。

同じループでForと何が違うの？と思うかもしれません。実際、同じことをしようと思えばどちらを使ってもできます。

使い分けとして、データ量が固定の範囲をループさせる場合はForを使い、データがどんどん追加されていくようなタイプの範囲をループさせる場合はDo-Whileを使うという感じです。

条件分岐(If文)

ある条件が満たされる場合のみ処理を実行することができます。

If 条件 Then
　処理
End If
が基本となります。

Sub test()

If 5 >= 5 Then
  MsgBox "Hello" '表示される
End If

If 5 > 5 Then
  MsgBox "World" ' 表示されない
End If

If "5" >= 5 Then
  MsgBox "!!!" ' 表示される
End If

End Sub

Sub test()

If 5 >= 5 Then

MsgBox "Hello" '表示される

End If

If 5 > 5 Then

MsgBox "World" ' 表示されない

End If

If "5" >= 5 Then

MsgBox "!!!" ' 表示される

End If

End Sub

このように書くことができます。

既に少し説明しましたが、VBAでは文字と数値をうまい具合に扱ってくれます。一般的なプログラミングでは数値と文字は比較できないので、例えば”5″と5は比較できません。この辺りの特徴は少し意識しておいたほうがいいかもしれません。

If文ではだいたい同時ElseIfやElseも説明されていることが多いですが、とりあえず今の段階では使わなくても大丈夫です。

実用例

ここまでの説明で少し実用的なものを作ってみます。Sheet1のデータに条件を1つ通してSheet2にコピーしてみます。

Sheet1には2列データが入っていて、1列目には名称、2列目には数量を入れてあります。1列目が空白になるまでループし、2列目が0の場合はコピーしないという処理をおこないます。

targetRow = 1 '書き込み対象行

r = 2
Do While Sheets("Sheet1").Cells(r, 1).Value <> ""

  n = Sheets("Sheet1").Cells(r, 1).Value
  q = Sheets("Sheet1").Cells(r, 2).Value
  
  If q <> "0" Then
    
    Sheets("Sheet2").Cells(targetRow, 1).Value = n
    Sheets("Sheet2").Cells(targetRow, 2).Value = q
    rr = rr + 1
    
  End If
  
  r = r + 1
Loop

targetRow = 1 '書き込み対象行

r = 2

Do While Sheets("Sheet1").Cells(r, 1).Value <> ""

n = Sheets("Sheet1").Cells(r, 1).Value

q = Sheets("Sheet1").Cells(r, 2).Value

If q <> "0" Then

Sheets("Sheet2").Cells(targetRow, 1).Value = n

Sheets("Sheet2").Cells(targetRow, 2).Value = q

rr = rr + 1

End If

r = r + 1

Loop

非常に簡単な例ですが、手作業では困難な程度の量になってくると自動化が役に立つと思います。

2019-12-172021-07-29

VBA 重複削除

重複を取り除く方法はいくつかあると思うけど、ネット上で一番有名なdictionaryを使う方法を採用。

Sub DeleteDuplicate()

Set dic = CreateObject("scripting.dictionary")

For Each r In Selection
  If Not dic.exists(r.Value) Then dic.Add r.Value, ""
Next

k = dic.keys
For i = 0 To dic.Count - 1
  Sheets("Sheet2").Cells(i + 1, 1).Value = k(i)
Next i

End Sub

Sub DeleteDuplicate()

Set dic = CreateObject("scripting.dictionary")

For Each r In Selection

If Not dic.exists(r.Value) Then dic.Add r.Value, ""

k = dic.keys

For i = 0 To dic.Count - 1

Sheets("Sheet2").Cells(i + 1, 1).Value = k(i)

Next i

End Sub

少し違うバージョン

Sub DeleteDuplicate()
 
Set dic = CreateObject("scripting.dictionary")

Set w = ActiveSheet

For r = 2 To 4111

  k = w.Cells(r, 1).Value
  v = w.Cells(r, 2).Value

  If Not dic.exists(k) Then dic.Add k, v
  
Next

kk = dic.keys
vv = dic.items

For i = 0 To dic.Count - 1
  w.Cells(i + 1, 4).Value = kk(i)
  w.Cells(i + 1, 5).Value = vv(i)
Next i
 
End Sub

Sub DeleteDuplicate()

Set dic = CreateObject("scripting.dictionary")

Set w = ActiveSheet

For r = 2 To 4111

k = w.Cells(r, 1).Value

v = w.Cells(r, 2).Value

If Not dic.exists(k) Then dic.Add k, v

kk = dic.keys

vv = dic.items

For i = 0 To dic.Count - 1

w.Cells(i + 1, 4).Value = kk(i)

w.Cells(i + 1, 5).Value = vv(i)

Next i

End Sub

2019-12-112020-01-15

VBA 関数の参照先アドレス(行)の増減

大量の関数を複写や移動するとき、参照先アドレスの数値(行)だけ一括で増減したいときがある。

例えばデータ用のシートに対して印刷用のシートからの参照していて、行数の関係が対応していないためそのまま複写できない場合など。

今回は式の中にアドレスが1つだけの場合を想定している。

Sub AddSub()
 
sumValue = InputBox("行加算")
 
For Each cell In Selection
 
 targetRowValue = cell.Value ' sheet!A80
 
 If targetRowValue = "" Or Left(targetRowValue, 1) <> "#" Then GoTo brk
 
 tmp = InStr(targetRowValue, "!")
 targetAddress = Mid(targetRowValue, tmp + 1) ' A2
 targetSheetName = Left(targetRowValue, tmp) ' sheet!
 
 tmp = StrReverse(targetAddress & "9")
 tmp = Val(tmp)
 tmp = StrReverse(tmp)
 targetAddressNum = Left(tmp, Len(tmp) - 1) ' 2
 
 targetAddressAsc = Replace(targetAddress, targetAddressNum, "") ' A
  
 cell.Value = targetSheetName & targetAddressAsc & (0 + targetAddressNum + sumValue)
  
brk:
 
Next
 
End Sub

Sub AddSub()

sumValue = InputBox("行加算")

For Each cell In Selection

targetRowValue = cell.Value ' sheet!A80

If targetRowValue = "" Or Left(targetRowValue, 1) <> "#" Then GoTo brk

tmp = InStr(targetRowValue, "!")

targetAddress = Mid(targetRowValue, tmp + 1) ' A2

targetSheetName = Left(targetRowValue, tmp) ' sheet!

tmp = StrReverse(targetAddress & "9")

tmp = Val(tmp)

tmp = StrReverse(tmp)

targetAddressNum = Left(tmp, Len(tmp) - 1) ' 2

targetAddressAsc = Replace(targetAddress, targetAddressNum, "") ' A

cell.Value = targetSheetName & targetAddressAsc & (0 + targetAddressNum + sumValue)

brk:

End Sub

2019-11-202020-01-16

VBA フォルダ作成

以前フォルダの構成をエクセルに書き出す機能を作ってみた。

VBA フォルダ・ファイルのリンクの一覧

逆にエクセルからフォルダを作成できると便利という場面も多いので作ってみた。

Sub CreateFolder()

Set w = Sheets("表紙")

basePath = Application.ActiveWorkbook.Path

r = 1
Do While w.Cells(r, 1).Value <> ""

  targetPath = basePath & "\" & w.Cells(r, 1).Value
  
  If "" <> Dir(targetPath, vbDirectory) Then
    MsgBox w.Cells(r, 1).Value & "は既に存在します。"
    Exit Sub
  End If

r = r + 1
Loop

r = 1
Do While w.Cells(r, 1).Value <> ""

  targetPath = basePath & "\" & w.Cells(r, 1).Value
  If "" = Dir(targetPath, vbDirectory) Then MkDir (targetPath) ' 指定が重複してた場合
  
r = r + 1
Loop

MsgBox "完了しました。"

End Sub

Sub CreateFolder()

Set w = Sheets("表紙")

basePath = Application.ActiveWorkbook.Path

r = 1

Do While w.Cells(r, 1).Value <> ""

targetPath = basePath & "\" & w.Cells(r, 1).Value

If "" <> Dir(targetPath, vbDirectory) Then

MsgBox w.Cells(r, 1).Value & "は既に存在します。"

Exit Sub

End If

r = r + 1

Loop

r = 1

Do While w.Cells(r, 1).Value <> ""

targetPath = basePath & "\" & w.Cells(r, 1).Value

If "" = Dir(targetPath, vbDirectory) Then MkDir (targetPath) ' 指定が重複してた場合

r = r + 1

Loop

MsgBox "完了しました。"

End Sub