ねこになりたい

おふとんと朝の別れをするのが辛い人向けです。正論で殴らず見守ってあげてください。

Excelで行を追加 or 編集するテスト

SQLのINSERT, UPDATEまがいの動作をする試作品。

(DELETEは・・・しまった忘れてた!)

 

たぶん、家計簿によく似た何かが作れるはず。

英文字をNoに入れることで、後からソート処理しやすくしました。
(Noを001などのように、単純に整数のみとする場合は必要ないです)

 

文字切り抜きは、こちらから拝借しました。

vbabeginner.net

サンプル

f:id:Arpino:20200531120854p:plain

 

使い方はサンプル画像を参考にボタン、ラジオボタンを配置した後で、機能別にマクロを登録すればOKです。

追加するA列目のNOは、sort.Addの箇所で修正します。C2セルで追加されたジャンル名とマッピングさせるイメージです。

修正する場合は、対象とするNOをD3セルに入力してください。

 

注意点としては、デフォルトでは英文字2桁、数字2桁でNOが登録されることです。
整数部分の桁数を変更するには、設定用ソースのintCodeForSearchを変更してやる必要があります。

 

```Excel VBA
〜
Sub Macro1()
'
' Macro1 Macro
'
Dim intInsertNo As String ' 挿入位置
Dim intSum As Integer ' 挿入したいソート連番の合計数
Dim intSearchStartNo As Integer ' 検索したい始点
Dim intSearchEndNo As Integer ' 検索したい終点
Dim rngSearchRange As Range ' 検索範囲
Dim rngSearchResultNo As Range ' 検索結果
Dim intSearchResultNo As Integer ' 検索結果(Integer)
Dim rngSearch As Range ' 検索用のRange
Dim intEndRow As Integer ' 行の終点
Dim str As String, i As Integer, cnt As Integer

' マップ用
Dim sort As Object
Dim Keys() As Variant
Dim code As String

' 編集カラム
Dim currentUpdateColumn As Integer

' 次のカラム
Dim nextColumn As Integer

' UPDATE文
Dim updateSQL As String

Dim msg As Integer
msg = MsgBox("指定した操作を実行しますか?", vbYesNo + vbInformation, "確認")

If msg = 6 Then
Set sort = CreateObject("Scripting.Dictionary")
' ジャンルを増やす場合はここを編集する
sort.Add "食料品", "AA"
sort.Add "日用品", "BB"
sort.Add "文房具", "CC"
Keys = sort.Keys
If optInsert = True Then
' 追加
For i = 0 To sort.Count - 1
str = str & Keys(i) & " : " & sort.Item(Keys(i)) & vbCrLf

' 編集カラム
currentUpdateColumn = Range(startCompileInsertColumn & startCompileInsertRow).Column - 1

If Cells(startCompileInsertRow, currentUpdateColumn).Value = Keys(i) Then

' 始点を検索
intEndRow = Range(searchColumn + startRow).End(xlDown).Row
Set rngSearch = Range(searchColumn + startRow & ":" & searchColumn & intEndRow)
intSearchStartNo = rngSearch.Find(What:=sort.Item(Keys(i))).Row

'合計数を検索
intSum = WorksheetFunction.CountIf(Range(searchColumn + startCntRow & ":" & searchColumn & intEndRow), sort.Item(Keys(i)) & "*")

'終点を検索
intSearchEndNo = intSearchStartNo + intSum - 1

' 挿入位置を確定
intInsertNo = intSearchEndNo + 1

If intInsertNo <> "" Then
Rows(intInsertNo).Insert

' 番号
If intSum + 1 < 10 Then
' 10文字未満は0をつける
With Range(searchColumn & intInsertNo)
.Value = sort.Item(Keys(i)) & "0" & intSum + 1
.Font.Color = RGB(255, 0, 0)
End With
Else
' 10文字以上はそのまま
With Range(searchColumn & intInsertNo)
.Value = sort.Item(Keys(i)) & intSum + 1
.Font.Color = RGB(255, 0, 0)
End With
End If

For m = 1 To cntColumnCompileNo
' 次のカラムへ
nextColumn = nextColumn + 1

' 編集するカラムを次に移動する
currentUpdateColumn = Range(startCompileInsertColumn & startCompileInsertRow).Column + nextColumn

' 値を詰める
With Range(searchColumn & intInsertNo).Offset(0, nextColumn)
.Value = Cells(startCompileInsertRow, currentUpdateColumn).Value
.Font.Color = RGB(255, 0, 0)
End With
Next

' INSERT文の作成(カラムの長さに応じて要調整)
If m = cntColumnCompileNo + 1 Then
With Range(searchColumn & intInsertNo)
.Offset(0, nextColumn + 1).Value = "追加"
.Offset(0, nextColumn + 1).Font.Color = RGB(255, 0, 0)
.Offset(0, nextColumn + 1).HorizontalAlignment = xlCenter
.Offset(0, nextColumn + 2).Value = _
"INSERT INTO " & Range(tableName).Value & " VALUES(" & _
"'" & Range(searchColumn & intInsertNo).Value & "'," & _
"'" & Range(searchColumn & intInsertNo).Offset(0, 1).Value & "'," & _
"'" & Range(searchColumn & intInsertNo).Offset(0, 2).Value & "'," & _
"'" & Range(searchColumn & intInsertNo).Offset(0, 3).Value & "'," & _
"'" & Range(searchColumn & intInsertNo).Offset(0, 4).Value & "'," & _
"'" & Range(searchColumn & intInsertNo).Offset(0, 5).Value & "'," & _
"'" & Range(searchColumn & intInsertNo).Offset(0, 6).Value & "'," & _
"SYSDATE);"
.Offset(0, nextColumn + 2).Font.Color = RGB(255, 0, 0)
End With
End If

' 編集欄をリセット
Range("E2:H2").ClearContents
End If
End If
Next i
Else
' 更新
For i = 0 To sort.Count - 1
str = str & Keys(i) & " : " & sort.Item(Keys(i)) & vbCrLf

' 編集カラム
currentUpdateColumn = Range(startCompileUpdateColumn & startCompileUpdateRow).Column - 1

If Cells(startCompileUpdateRow, currentUpdateColumn).Value = Keys(i) Then
intInsertNo = Range(startCompileUpdateColumn & startCompileUpdateRow).Value
code = Left(intInsertNo, intCodeForSearch)
End If
Next i

If Cells(startCompileUpdateRow, currentUpdateColumn).Value <> "" Then
' 始点を検索
intEndRow = Range(searchColumn + startRow).End(xlDown).Row
Set rngSearch = Range(searchColumn + startRow & ":" & searchColumn & intEndRow)
intSearchStartNo = rngSearch.Find(What:=Left(Range(startCompileUpdateColumn & startCompileUpdateRow).Value, 1)).Row

'合計数を検索
intSum = WorksheetFunction.CountIf(Range(searchColumn + startRow & ":" & searchColumn & intEndRow), code & "*")

'終点を検索
intSearchEndNo = intSearchStartNo + intSum - 1

' 更新位置を確定
intInsertNo = CutLeft(intInsertNo, intCodeForSearch)

'検索範囲を決める
Set rngSearchRange = Range(searchColumn & intSearchStartNo & ":" & searchColumn & intSearchEndNo)

'何列目かを求める
Set rngSearchResultNo = rngSearchRange.Find(What:=Range(startCompileUpdateColumn & startCompileUpdateRow))

If Not rngSearchResultNo Is Nothing Then
' 数値に変換
intSearchResultNo = rngSearchResultNo.Row

For i = 1 To cntColumnCompileNo
' 次のカラムへ
nextColumn = nextColumn + 1

' 編集するカラムを次に移動する
currentUpdateColumn = Range(startCompileUpdateColumn & startCompileUpdateRow).Column + nextColumn

' 値を変更
If Cells(startCompileUpdateRow, currentUpdateColumn).Value <> "" Then
With Range(searchColumn & intSearchResultNo).Offset(0, nextColumn)
.Value = Cells(startCompileUpdateRow, currentUpdateColumn).Value
.Font.Color = RGB(0, 0, 255)
End With
End If
Next i

If i = cntColumnCompileNo + 1 Then
' 操作欄
With Range(searchColumn & intSearchResultNo).Offset(0, nextColumn + 1)
.Value = "更新"
.Font.Color = RGB(0, 0, 255)
.HorizontalAlignment = xlCenter
End With

' SQLを作成
updateSQL = "UPDATE " & Range(tableName).Value & " SET "

currentUpdateColumn = Range(startCompileUpdateColumn & startCompileUpdateRow).Column + 1

' SET句(最後の列は除外)
For N = 1 To cntColumnCompileNo - 1
If Cells(startCompileUpdateRow, currentUpdateColumn).Value <> "" Then
updateSQL = updateSQL + " " & Range(searchColumn & startRow).Offset(0, N) & " = '" & Cells(startCompileUpdateRow, currentUpdateColumn).Value & "' "

If N <> cntColumnCompileNo - 1 Then
updateSQL = updateSQL + ","
End If
End If
currentUpdateColumn = currentUpdateColumn + 1
Next

' WHERE句
updateSQL = updateSQL + " WHERE " & Range(searchColumn & startRow) & " = '" & Range(startCompileUpdateColumn & startCompileUpdateRow) & "';"

' UPDATE文を張り付ける
With Range(searchColumn & intSearchResultNo).Offset(0, nextColumn + 2)
.Value = updateSQL
.Font.Color = RGB(0, 0, 255)
End With

' 編集欄をリセット
Range("D3:H3").ClearContents
End If
End If
Else
MsgBox ("商品Noが入力されていません")
End If
End If
End If
End Sub

Function CutLeft(s, i As Long) As String
Dim iLen As Long '// 文字列長

'// 文字列ではない場合
If VarType(s) <> vbString Then
Exit Function
End If

iLen = Len(s)

'// 文字列長より指定文字数が大きい場合
If iLen < i Then
Exit Function
End If

'// 指定文字数を削除して返す
CutLeft = Right(s, iLen - i)
End Function 〜 ```

以下チェックボタン用

```Excel VBA
〜
Sub btnCheck_Click()
Dim intEndRow As Integer ' 行の終点
Dim cntLength As Integer ' 行の終点
Dim cntNext As Integer ' 行の終点
Dim confirmWindow As Integer ' 確認用ダイアログ
Dim intSearchStartNo As Integer ' 検索したい始点
Dim currentName As String
  confirmWindow = MsgBox("チェックをしますか?", vbYesNo + vbInformation, "確認")
  If confirmWindow = 6 Then

intEndRow = Range(searchColumn & startCntRow).End(xlDown).Row

For i = startCntRow To intEndRow
cntLength = LenB(Range(searchColumn & startCntRow + cntNext).Offset(0, 1).Value)

' 基準値以上ならエラーを出す
If cntLength > maxLength Then
MsgBox ("BIHINCD:" & Range(searchColumn & startCntRow + cntNext) & vbCrLf & _
"「" & Range(searchColumn & startCntRow + cntNext).Offset(0, 1).Value & vbCrLf & "」の文字数を減らしてください。" _
& vbCrLf & "サイズ:" & cntLength)
Range(searchColumn & startCntRow + cntNext).Offset(0, 1).Interior.Color = RGB(255, 255, 0)
End If

cntNext = cntNext + 1
Next i

MsgBox ("チェックが終わりました。")

End If
End Sub 〜 ```

以下設定用

```Excel VBA
〜
' テーブル名
Global Const tableName = "B1"

' 検索する列
Global Const searchColumn = "A"

' 検索する列のキャプション列
Global Const startRow = "4"

' カウント開始列
Global Const startCntRow = "5"

' 行数
Global Const cntColumn = 2

' INSERT(編集用)セル
Global Const startCompileInsertColumn = "D"
Global Const startCompileInsertRow = "2"

' UPDATE(編集用)セル
Global Const startCompileUpdateColumn = "D"
Global Const startCompileUpdateRow = "3"

' 編集用カラム総数
Global Const cntColumnCompileNo = 7

' 検索用コードを先頭から抜き出す数
Global Const intCodeForSearch = 3

' 品名の最大文字数
Global Const maxLength = 42 〜 ```

フラグ判定

```Excel VBA
〜
Global optInsert As Boolean
Global optUpdate As Boolean

Sub swtInsert()
optInsert = True
optUpdate = False
End Sub

Sub swtUpdate()
optUpdate = True
optInsert = False
End Sub 〜 ```

リセットボタン

```Excel VBA
〜
Sub btnCheck_Click()
Dim confirmWindow As Integer ' 確認用ダイアログ
Dim startColumn As Integer
Dim endRow As Integer

confirmWindow = MsgBox("表示中のレコードを全て消去しますか?" & vbCrLf & "※消去する前には、必ずバックアップを残すようにしましょう。", vbYesNo + vbInformation, "確認")

If Range(searchColumn & startCntRow).End(xlDown).Row < 10000 Then
endRow = Range(searchColumn & startCntRow).End(xlDown).Row

If confirmWindow = 6 Then
startColumn = Range(searchColumn & startCntRow).Column
Range(Cells(CInt(startCntRow), startColumn), Cells(endRow, cntColumnCompileNo + 3)).Clear

MsgBox ("リセットしました。")
End If
Else
' オーバーフロー対策
MsgBox ("レコードが1件もないか、列数が多すぎます。")
End If
End Sub 〜 ```