月別アーカイブ: 2023年11月

VBA: 数字からセルのX座標変換

投稿日時: 投稿者: 
Function NumToAbc(n As Integer) As String
’数字からセルのX座標変換 - AZZ(1378)列まで対応
If n < 27 Then
NumToAbc = Chr(64 + n)
Else
NumToAbc = Chr(64 + ((n - 1) \ 26)) & Chr(65 + ((n - 1) Mod 26))
End If
End Function

VBA: 条件付き書式_自動セット

投稿日時: 投稿者: 

Sub 条件付き書式_自動セット(a As Boolean)
	'シート「リスト」のC列の値と同じ値が見つかった場合、そのC列の背景色を条件式に登録する
	YY = 2
	CL = 0
	Columns("H:H").Select
	Do While Sheets("リスト").Cells(YY, 3) <> ""
		Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=" & Chr(34) & Sheets("リスト").Cells(YY, 3) & Chr(34)
		Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
		Selection.FormatConditions(1).Interior.Color = Sheets("リスト").Cells(YY, 3).Interior.Color
		Selection.FormatConditions(1).StopIfTrue = False
		'Exit Do
		YY = YY + 1
	Loop
End Sub

VBA: Wクリック時にセルの値をクリップボードへ

投稿日時: 投稿者: 

'Wクリック時にセルの値をクリップボードへ
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
	Dim moji As String
	If Target.Value <> "ここをWクリック" Then
		Application.StatusBar = "コピーセル対象外"
	Else
		moji = Cells(Target.Row, Target.Column + 7)
		Application.StatusBar = "Copy: " & moji
		CreateObject("WScript.Shell").Exec("clip").StdIn.Write moji
	End If
	Cancel = True
End Sub

VBA:クリップボードの値貼り付け＆コピー

投稿日時: 投稿者: 

Private Sub SetCB(ByVal str As String)
'クリップボードに文字列を格納
  With CreateObject("Forms.TextBox.1")
	.MultiLine = True
	.Text = str
	.SelStart = 0
	.SelLength = .TextLength
	.Copy
  End With
End Sub

Private Sub GetCB(ByRef str As String)
'クリップボードから文字列を取得
  With CreateObject("Forms.TextBox.1")
	.MultiLine = True
	If .CanPaste = True Then .Paste
	str = .Text
  End With
End Sub

VBA: セルコメント

投稿日時: 投稿者: 

'コメントを挿入前に既存分があれば保持して末尾に追加
If TypeName(Cells(i, X).Comment) = "Comment" Then
strTitle = Cells(i, X).Comment.Text &amp; vbCrLf &amp; strTitle
Cells(i, X).ClearComments
End If
Cells(i, X).AddComment strTitle
Cells(i, X).Comment.Shape.Width = 200

 

VBA:パワポ: 一括テキスト処理

投稿日時: 投稿者:

対象は図形、表の2つ。
一括でフォント統一、文字置換、図形余白を設定。

Sub 図形調整()
	cnt = 0
	For Each sld In ActivePresentation.Slides
		For Each shp In sld.Shapes
			If shp.HasTextFrame Then
				cnt = cnt + 1
				shp.TextFrame.TextRange.Font.Name = "Meiryo UI"
				shp.TextFrame.TextRange.Font.NameFarEast = "Meiryo UI"
				shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "：", ":")
				shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "（", "(")
				shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "）", ")")
				' 0.5 = 0.02 cm / 1 = 0.04 cm
				shp.TextFrame.MarginLeft = 1
				shp.TextFrame.MarginRight = 1
				shp.TextFrame.MarginTop = 1
				shp.TextFrame.MarginBottom = 1
			End If
		Next shp
	Next sld
	MsgBox "Done: " &amp; cnt
End Sub

Sub TextBox調整()
	cnt = 0
	For Each sld In ActivePresentation.Slides
		For Each shp In sld.Shapes
			If shp.HasTable Then
				With shp.Table
				For i = 1 To .Columns.Count
					For j = 1 To .Rows.Count
						.Cell(j, i).Shape.TextFrame.TextRange.Font.Name = "Meiryo UI"
						.Cell(j, i).Shape.TextFrame.TextRange.Font.NameFarEast = "Meiryo UI"
						' 0.5 = 0.02 cm / 1 = 0.04 cm
						.Cell(j, i).Shape.TextFrame.MarginLeft = 4
						.Cell(j, i).Shape.TextFrame.MarginRight = 4
						.Cell(j, i).Shape.TextFrame.MarginTop = 1
						.Cell(j, i).Shape.TextFrame.MarginBottom = 1
					Next j
				Next i
				End With
			End If
		Next shp
	Next sld
	MsgBox "Done: " &amp; cnt
End Sub