「VBA(Excel)」カテゴリーアーカイブ

Excelセル検索

投稿日時: 投稿者: 
Sub find_cell()

	Dim Found As Object, strID As String
	
	'sheet1内のA列を検索（完全一致）
	Set Found = Worksheets(“sheet1").Columns(“A:A").Find(strID, LookAt:=xlWhole)

	If Found Is Nothing Then
		MsgBox “「" & strID & “」は見つかりませんでした。"
	Else
		'見つかったセルの右隣(B=2列目)の値をゲット
		MsgBox Worksheets(“sheet1").Cells(Found.Row, 2)
		'その値を現在、セルがある場所にセット
		Cells(ActiveCell.Row, ActiveCell.Column) = Worksheets(“sheet1").Cells(Found.Row, 2)
	End If

End Sub

指定セル内の指定文字列を赤色に変更

投稿日時: 投稿者: 
Sub SEARCH_WORD()

	Dim chkVAL As String, FX As Integer
	
	chkVAL = InputBox(“Keyword(該当文字列を赤色にします)", “SEARCH")
	If chkVAL = “" Then Exit Sub

	For Each c In Selection
		
		FX = InStr(1, c.Value, chkVAL)
		If FX > 0 Then c.Characters(Start:=FX, Length:=Len(chkVAL)).Font.ColorIndex = 3
	Next

End Sub

隠しシートの表示

投稿日時: 投稿者:

通常はメニューの「書式」-「シート」-「再表示」で非表示シートを表示可能。

しかし、マクロで「VeryHidden」をセットされると「再表示」でも見ることができない。
例）Sheets(“aaa”).Visible = xlVeryHidden

VeryHiddenのシートが存在するかを確認する方法：
１）VBAエディター上のイミディエイトボックスを表示
２）存在するシート数を確認する
　?sheets.Count
　4
３）表示されているシート数が4未満の場合は、VeryHiddenがあり得る
４）下記のコマンドで強制表示させる（イミディエイトボックス内）
 for i=1 to 4:Sheets(i).Visible=true:next

ピボット並び替え＆上位フィルター

投稿日時: 投稿者: 
Sub run()
	'引数：並べ替えのフィールド名、対象のシート名、Pivot実データの開始Y番号,TOP幾つまでを表示するか
	pivot_SORT_TOP “TITLE", “Sheet4", 5, 10
End Sub

'X軸は日付など、並び替え可能な項目であること
Sub pivot_SORT_TOP(CMname As String, pivot_sheet As String, Y As Long, TOP As Integer)

	Dim X As Long, CH As String

	Sheets(pivot_sheet).Select

	On Error Resume Next
	'縦の項目を一度、全部表示にする
	For i = 1 To ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems.Count
		ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems(i).Visible = True
	Next
	
	'Pivotの末列の座標を探す
	X = 2
	Do While Cells(Y – 1, X) <> “": X = X + 1: Loop
	X = X – 1
	
	'横列の昇順並び替え
	Cells(Y – 1, 2).Select
	Selection.Sort Order1:=xlAscending, Type:=xlSortLabels, OrderCustom:=1, _
		Orientation:=xlLeftToRight, SortMethod:=xlPinYin
	
	'並び替えたい列を選択
	Cells(Y, X).Select
	'Range(Chr(64 + X) & Y).Select
	
	'X,Y座標をR1C1形式に変換
	CH = “R" & Y & “C" & X
	'末列を降順でSORT
	Selection.Sort Key1:=CH, Order1:=xlDescending, Type:=xlSortValues, _
		OrderCustom:=1, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
	
	'表示項目がTOP指定より多い場合は、フィルター処理
	If ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems.Count > TOP Then
	
		On Error Resume Next
		'TOP以降は非表示する
		For i = TOP + 1 To ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems.Count
			ActiveSheet.PivotTables(1).PivotFields(CMname).PivotItems(i).Visible = False
		Next
	End If
	On Error GoTo 0
	
End Sub

グラフのバーをグループ単位で色分け

投稿日時: 投稿者: 
'グラフのバーをグループ単位で色分け
'大前提：実行前に対象のグラフが選択されていること
Sub Set_Color_Bar()
	
	Dim i As Integer, N As Integer

	'バーの数分だけループ（この例では13個）
	For i = 1 To ActiveChart.SeriesCollection.Count
		N = Val(Right(ActiveChart.SeriesCollection(i).Name, 2))
		'何番目のバーを処理しているか
		If i < 5 Then
			'最初の4本までは青系のバーにする
			Bar_attr i, 33
		ElseIf i < 9 Then
			'最初の5～8本は黄系のバーにする
			Bar_attr i, 6
		Else
			'最初の9本目以降は紫系のバーにする
			Bar_attr i, 7
		End If
	Next
	
	'おまけ
	'ActiveChart.SeriesCollection(i).Name
	'これには「WK01」などの凡例の名称が入る
	
End Sub

'指定バーの色を変更
Sub Bar_attr(bar As Integer, c As Integer)
			'何番目のバーか、色番号
	On Error GoTo pass
	'対象のバーを選択
	ActiveChart.SeriesCollection(bar).Select
	'グラデーションセット
	Selection.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=4, Degree:=0.231372549019608
	Selection.Fill.Visible = True
	'色をセット
	Selection.Fill.ForeColor.SchemeColor = c
pass:
	On Error GoTo 0

End Sub

全シート内PIVOTをリフレッシュ

投稿日時: 投稿者: 
'全シート内のPIVOTを無条件リフレッシュ
Sub ALL_PIVOT_UPDATE()

	If MsgBox(“全Pivotを一括更新します。" & vbCrLf & _
		“1Pivot xx秒ほどかかります。", vbYesNo) <> vbYes Then Exit Sub
	
	'PIVOTが無いシートはエラーになるため、無視するように設定
	On Error Resume Next
	'全シートを順番に更新
	For i = 1 To ActiveWorkbook.Sheets.Count
		Sheets(i).Activate
		'PIVOTのリフレッシュ
		ActiveWorkbook.Sheets(i).PivotTables(1).PivotCache.Refresh
	Next
	'エラー処理を有効にする
	On Error GoTo 0
	
	MsgBox “done!"

End Sub

選択オブジェクトのグラデーション化②sub

投稿日時: 投稿者: 
'選択物のグラデーション化（相手は必ず黒となる）
Sub 縦下黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientHorizontal, 1, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientHorizontal, Variant:=1, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 縦上黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientHorizontal, 2, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientHorizontal, Variant:=2, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 縦内黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientHorizontal, 3, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientHorizontal, Variant:=3, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 縦外黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientHorizontal, 4, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientHorizontal, Variant:=4, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 横右黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientVertical, 1, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=1, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 横左黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientVertical, 2, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=2, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 横内黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientVertical, 3, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 横外黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientVertical, 4, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=4, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

選択オブジェクトのグラデーション化①main

投稿日時: 投稿者:

選択したオブジェクトの色をグラデーション化する
起動時にグラデーション用のボタンを作成＆配置

Sub Auto_open()
	Dim cbrWiz As CommandBar
	Dim cbcMenu As CommandBarControl
	Dim ctlInsert As CommandBarButton
	On Error Resume Next
	' コマンド バーが既に存在するかどうかを確認します。
	Set cbrWiz = CommandBars(CBR_INSERT)
	' コマンド バーが存在しない場合は作成します。
	If cbrWiz Is Nothing Then
		Err.Clear
		Set cbrWiz = CommandBars.Add(CBR_INSERT)
		' コマンド バーを表示します。
		cbrWiz.Visible = True
	  
		'グラデーションメニューの追加
		Set cbcMenu = cbrWiz.Controls.Add(Type:=msoControlPopup)
		cbcMenu.Caption = “Gradation"
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して縦下黒のグラデーションセット"
			.Tag = “縦下黒"
			.OnAction = “縦下黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して縦上黒のグラデーションセット"
			.Tag = “縦上黒"
			.OnAction = “縦上黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して縦内黒のグラデーションセット"
			.Tag = “縦内黒"
			.OnAction = “縦内黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して縦外黒のグラデーションセット"
			.Tag = “縦外黒"
			.OnAction = “縦外黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して横右黒のグラデーションセット"
			.Tag = “横右黒"
			.OnAction = “横右黒"
			.BeginGroup = True
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して横左黒のグラデーションセット"
			.Tag = “横左黒"
			.OnAction = “横左黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して横内黒のグラデーションセット"
			.Tag = “横内黒"
			.OnAction = “横内黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して横外黒のグラデーションセット"
			.Tag = “横外黒"
			.OnAction = “横外黒"
		End With
		
	Else
	  ' 既存のコマンド バーを表示します。
	  cbrWiz.Visible = True
	End If
End Sub

'終了時はボタンを削除する
Sub Auto_close()
	On Error Resume Next
	' 存在するコマンド バーを削除します。
	CommandBars(CBR_INSERT).Delete
End Sub

マクロ用ボタンセット

投稿日時: 投稿者: 
Sub CREATE_MACRO_BUTTON()
	'set button(size:開始x,開始y,幅x,高さy)
	ActiveSheet.Buttons.Add(100, 10, 150, 20).Select
	'set macro name
	Selection.OnAction = “macro_excel_file.xls!macro_name"
	'set button title
	Selection.Characters.Text = “MACRO TITLE NAME"
End Sub

IEフォームに値をセットしてSUBMIT

投稿日時: 投稿者:
返信

Excel C列の値をIE上のフィールドにセットしてSUBMIT

Sub batch_all_check()

	Dim IE As Object
	Dim LenX As Integer, PP As String
	Dim Y As Integer, HTML As String
	
	Set IE = CreateObject(“internetExplorer.application")
	IE.Navigate “https://www.xxx"
	IE.Visible = True
	
	Do While IE.Busy = True: DoEvents: Loop
	Do While IE.Busy = True: DoEvents: Loop
	Do While IE.Busy = True: DoEvents: Loop
	
	For Y = 3 To 4002
		
		PP = Cells(Y, 3)
		If PP = “" Then Exit For
		
		PP = UCase(Replace(PP, “-", “"))
		LenX = Len(PP)
		
		If LenX <> 20 Then
			Cells(Y, 5) = “length error"
			Exit For
		End If
	
		Do While IE.Busy = True: DoEvents: Loop
		'文字列を分解してそれぞれのフィールドにセット
		IE.Document.Form1.igtxtwtxedPidPart01.Focus
		IE.Document.Form1.igtxtwtxedPidPart01.Value = Left(PP, 2)
		IE.Document.Form1.igtxtwtxedPidPart02.Focus
		IE.Document.Form1.igtxtwtxedPidPart02.Value = Mid(PP, 3, 6)
		IE.Document.Form1.igtxtwtxedPidPart03.Focus
		IE.Document.Form1.igtxtwtxedPidPart03.Value = Mid(PP, 9, 5)
		IE.Document.Form1.igtxtwtxedPidPart04.Focus
		IE.Document.Form1.igtxtwtxedPidPart04.Value = Mid(PP, 14, 3)
		IE.Document.Form1.igtxtwtxedPidPart05.Focus
		IE.Document.Form1.igtxtwtxedPidPart05.Value = Mid(PP, 17, 4)
		IE.Document.Form1.igtxtwtxedPidPart01.Focus
		'theform.submit()
		IE.Document.Form1.identify_btnVerify.Click
		'ボタン(SUBMIT)をクリック
		Do While IE.Busy = True: DoEvents: Loop
		Do While IE.Busy = True: DoEvents: Loop
		Do While IE.Busy = True: DoEvents: Loop
		'html取り込み
		HTML = IE.Document.Body.innerHTml
	
		If InStr(1, HTML, “***") > 0 Then
			Cells(Y, 5) = “Hit"
		Else
			Cells(Y, 5) = “???"
		End If
	Next
	
	MsgBox “Done!"
	Set IE = Nothing

End Sub