ねこになりたい

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

Font

概要

 
Rangeオブジェクト.Font
太字などの書式を設定する。

プロパティ

項目が多いので、Withで一括して設定するとよい。

プロパティ名 説明 設定例
Name フォント名 "MS ゴシック"
Bold 太字

True

False

Italic 斜体

True

False

Underline 下線

True

False

Size 文字サイズ

任意の整数(単位はpt)

Color 文字色

RGB関数の値

TintAndShade 濃淡

-1 ~ 1の任意の数

-1:最も暗い

1 :最も明るい

ThemeFont テーマフォント

xlThemeFontMajor:見出し

xlThemeFontMinor:本文

xlThemeFontNone:使わない

ThemeColor テーマの色

xlThemeColorDark1:背景1

xlThemeColorDark2:背景2

xlThemeColorLight1:テキスト1

xlThemeColorLight2:テキスト2

xlThemeColorAccent1:アクセント1

xlThemeColorAccent2:アクセント2

xlThemeColorAccent3:アクセント3

xlThemeColorAccent4:アクセント4

xlThemeColorAccent5:アクセント5

xlThemeColorAccent6:アクセント6

サンプル

f:id:Arpino:20200531180705p:plain

 With Range("B2").Font
.Bold = True
.Size = 20
End With

With Range("D3").Font
.Underline = True
.TintAndShade = 0.5
End With

実行結果

f:id:Arpino:20200531180725p:plain

補足

実は1発で開けるセルの書式設定。そこそこ便利!

 ショートカットキー Ctrl + 1

FormulaR1C1

概要

 
Rangeオブジェクト.FormulaR1C1
セルに入力されている数式を取得し、別のセルに設定する。

サンプル

J2、J3セルの値を取得しJ7、J8セルに値を設定する。

f:id:Arpino:20200531130947p:plain

 

Range("J7:J8").FormulaR1C1 = Range("J2:J3").FormulaR1C1

実行結果

J2とJ3セルも相対参照でコピーされます。

f:id:Arpino:20200531131038p:plain



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 〜 ```

行き当たりばったりの、わがまま追体験ゴッコ

お題「#おうち時間

 

部屋の掃除をしていたら、びっしりと書かれた学生時代の手帳。

そして、デジタルカメラに積もり積もった写真が出てきて、気が付いたら8年前から遡って撮った写真と駄文をブログに書いていた。

 

事の発端は2012年2月の手帳である。

なんだか細々と書いてある。細かいことを色々と考えていたんだろう。

事前に色々と考えないと行動に移せなかったのだ。

f:id:Arpino:20200502203604j:plain

 

 

なんでもっとはやく投稿しなかったんだろう。

こんな無機質な文章じゃなくて、もっと生々しい文章が書けただろうに。

 

思い返すのが、なんで今なんだろう。

優しい顔をした虚無感だけが付きまとうが、それでも追体験ゴッコがしたくなった。

 

そして、意を決して画像をアップロード。

当時の手帳を見ながらキーボードを叩きはじめる。

 

賽は投げられた。もはや誰にも止められない。

arpino.hatenadiary.com

arpino.hatenadiary.com

arpino.hatenadiary.com

↓おまけ

arpino.hatenadiary.com

ひたすら写真をブログに投下しまくる。

すでに今月のファイル利用料が70%になっているが、他人事みたいな顔だ。

 

本当は思いつき次第補足していきたいが、この手の類は後から読み返すと布団に駆け込みたくなること請け合いなので、酒に酔った勢いで流れるように書いて放置してしまうが得策である。

もちろん、読む側からすると文章構成がガタガタで到底読めたものじゃないが・・・。

 

どうせテレビなんてつけても同じ話題ばかり。

仕事の流れだって同じ同じ繰り返し。

油断してると誰もが似たような悩みに突き当たってしまう。

くたびれ損の骨折り儲け。

 

だけど、それでも必死にしがみ付きたいのが人生ってもんじゃないか。

少しぐらい楽しみながら発狂したって、きっと罰は当たるまい。

Value

概要

 
Rangeオブジェクト.Value
セル範囲を取得・設定する。

サンプル

B2セルの値を取得し、B3セルに値を設定する。

f:id:Arpino:20200419164220p:plain

 

Debug.Print Range("B2").Value
Range("B3").Value = "(´・ω・`)焼肉食いてえ"

実行結果

f:id:Arpino:20200419164253p:plain

f:id:Arpino:20200419164305p:plain





 

補足

別シートからコピーする場合は、シート名を指定する。

Worksheets("シート名").Rangeオブジェクト.Value

サンプル

満員電車シートのセルをホーム乗車位置に移動するサンプル

 

↓こんな感じの3密地獄から

f:id:Arpino:20200531174256p:plain

f:id:Arpino:20200531174320p:plain

 

↓こっちに移動する

f:id:Arpino:20200531174435p:plain

Range("A3:B4").Value = Worksheets("満員電車").Range("C4:D5").Value

実行結果

f:id:Arpino:20200531174624p:plain