だめんずAWK'er (the men's awker)

Public Sub addsakura()
	Call addRightMenu("複数検索マーク")
	Call addRightMenu("sakuraエディタで開く","(&w)")
	Call addRightMenu("セル文字分割""(&h)") 
	Call addRightMenu("内容結合","(&b))
	Call addRightMenu("項番振り")
	Call addRightMenu("空欄補完") 
	Call addRightMenu("同色検索","(&s)")
	Call addRightMenu("名前作成")
	Call addRightMenu("指定範囲を図に変換")
End Sub

Sub delrightMenu同色検索()
	delRightMenu("同色検索")
End Sub

Public Sub addRightMenu(関数名 As String.Optional sShortout As String = "")
	Dim Newb As CommandBarControl

For Each c In CommandBars
		If(c.Controls.Count > 0) Then
			If c.Name = "Cell" Or c.Name = "List Range Popup" Then
				For i = c.Controls.Count To 1 Step 1
					If c.Controls(i).BeginGroup = dalse Then
						If c.Controls(i).Caption = sShortcut & 関数名 Then
							c.Controls(i) Delete
						Else
							If c.Controls(i).Caption = 関数名 Then 
								c.Controls(i).Delete
							Else
								If c.Controls(i).Caption = 関数名 & Shortcut Then
									c.Controls(i).Delete
								End If
							End If
						End If
					End If
				Next
				Set Newb  = c.Controls.Add() 
				Newb.Captions = Shortcut & 関数名
				Newb.OnAction = 関数名
			Else
				For i = c.Controls.Count To 1 Step -1
					If c.Controls(i).BeginGroup = dalse Then
						If InStr(c.Controls(i).Caption, "書式設定") > 0 Or _
							 InStr(c.Controls(i) Caption, "図として") > 0 Then
						End If
					End If
				Next
			End If
		End If
	Next
End Sub

Public Sub delRightMenu(関数名 As String, Optional sShortout As String = "")
	Dim Newb As CommandBarControl
	Debug.Print CommandBars.Count 
	For Each c In CommandBars
		If (c.Controls.Count > 0) Then
			If c.Name "Cell" Or c.Name = "List Range Popup" Then
				Debug.Print c.NameLocal & " : " & c.Name
				For i = c.Controls.Count To 1 Step -1
					If c.Controls(i).BeginGroup = dalse Then
						Debug.Print "   " & c.Controls(i).Caption
						If c.Controls(i).Captions = Shortout & 関数名 Then
							c.Controls(i).Delete
						End If
					End If
				Next
			End If
		End If
	Next 
End Sub

Sub 検索結果シート貼り付け()
	Dim ret
	Dim r As Range
	Dim adr As String
	Dim cnt As Long
	Dim psw As Boolean
	Dim mySht, adSht, ws As Worksheet

ret = Application.InputBox("検索文字列を入力してください")
	If TypeName (ret) <> "Boolean" Then
		cnt = 1
		For Each ws In Worksheets
			If ws.Name="検索結果″& ret Then 
				psw = True 
				Exit For 
			End If
		Next ws
		If psw Then 
			Set adSht = ws
			adSht.Cells.ClearContents
		Else
			Set adSht = Worksheets.Add 
			adSht.Name="検索結果″& ret 
		End If

For Each mySht In Worksheets
			If mySht.Name = adSht.Name Then GoTo LEND 
			With mySht.Cells
				Set r.Find (ret, LookIn:=xlValues, lookat:=xlPart)
				If Not r Is Nothing Then
					DoEvents
					adr = r.Address
					adSht.Cells (cnt, 1).Activate
					adSht.Cells (cnt, 1).Value = mySht.Name
					adSht.Cells (cnt, 2).Value = adr 
					adSht.Cells (cnt, 3).Value = r.Value 
					adSht.Hyperlinks.Add Anchor:=adSht.Cells (cnt, 3), Address:=mySht.Parent.Full Name, SubAddress:= mySht.Name & "!" & adr, TextToDisplay: =r.Value 
					Do
						DoEvents
						Set r = FindNext (r) 
						If r.Address = adr Then 
							Exit Do 
						Else 
							cnt = cnt + 1
							adSht.Cells (cnt, 1).Activate
							adSht.Cells (cnt, 1).Value = mySht.Name 
							adSht.Cells (cnt, 2).Value = r.Address 
							adSht.Cells (cnt, 3).Value = r.Value 
							adSht.Hyperlinks.Add Anchor:=adSht.Cells(cnt.3), Address: mySht.Parent.Full Name, SubAddress:= mySht.Name & "!" & r.Address, TextToDisplay:=r.Value
						End If
					Loop 
				End If
			End With
LEND:
		Next 
	End If
End Sub

Public Sub SplitCell()
	sep = InputBox("区切り文字を入力してください (default=スペース)")
	For Each cel In Selection.Cells
		cel.Activate
		If sep = "" Then sep = " "
		n = Split (ActiveCell.Text, sep)
		ncol = 1
		For i = 0 To UBound (n)
			If n (i) <> Then 
				Cells (ActiveCell.Row, ActiveCell.Column + ncol).NumberFormatLocal = "@"
				Cells (ActiveCell.Row, ActiveCell.Column + ncol) = n(i) 
				ncol = ncol + 1
			End If
		Next
	Next
End Sub

Public Sub UTF8CD2CHAR ()
	sz = ""
	bhex = False
	If (MsgBox ("16進ですか?", vbYesNo) = vbYes) Then 
		bhex True
	End If
	n = Val ("OxFe")
	For Each cel In Selection.Cells
		If (bhex) Then 
			szIn = UCase (Trim (cel.Text)) 
			If (Left (szIn, 2) = "&H") Then 
			ElseIf (Left (szIn, 1) = "H") Then 
				szIn = "&H" & Right (szin, Len (szIn) - 1)
			Elself (Left (szin, 2) = "OX") then
				szIn = "&H" & Right (szIn, Len (szIn) - 2)
			ElseIf (Right (szIn, 1) = "H")  Then 
				szIn = "&H" & Left (szIn, Len (szIn) - 1) 
			Else
				szIn = "&H" & szin 
			End If
		Else
		End If

sz = "&H" & Right (szIn.2) & Mid(szIn, 3, 2) 
		cel.Cells (1) = ChrW (Val (sz))
	Next
End Sub

Public Sub sakuraエディタで開く()
	Dim strTarg As String 
	Dim strDefaultPath As String 
	On Error GoTo er1
	
	'Debug.Print ActiveCell.Text

If ActiveCell.Hyperlinks.Count = 0 Then

100 szPa  = Right (ActiveSheet.Names.Item ("SAKURA_SRC"), Len (ActiveSheet.Names.Item ("SAKURA_SRC")) - InStr (1.ActiveSheet.Names.Item ("SAKURA_SRC"), """")) 
	szPa = Left (szPa, Len (szPa) - 1)

110 If szPa = "" Then
120 	szPa  = Right (ActiveWorkbook.Names.Item ("SAKURA_SRC"), Len (ActiveWorkbook.Names.Item ("SAKURA_SRC")) - InStr (1.ActiveWorkbook.Names.Item ("SAKURA SRC").""""))
	End If

If Right (szPa,1) = Then szPa Left (szPa.Len (szPa) - 1) 
	If szPa<>"" And Right (szPa,1) <> "\" Then szPa=  szPa & "\"
11:
		strTarg = ActiveCell.Text 
	Else
		strDefaultPath = ActiveWorkbook.Path 
		strTarg = ActiveCell.Hyperlinks (1).Address 
		If (IsFileName (strTarg) = False) Then
			Exit Sub
		End If
		If Left (strTarg,1) = "." Then
			strTarg = Replace (strTarg."/", "\")
			strTarg = ActiveWorkbook.Path & "\" & strTarg
		End If
	End If

pos = InStr (strTarg."(") 
	If (pos > 0) Then
		szFile = Trim (Left (strTarg, pos - 1))
		szElse = Right (strTarg, Len (strTarg) - pos)
		pos = InStr (szElse, ")")
		If pos > 0 Then 
			szLine = Left (szElse, pos - 1) 
		End If
		pos = InStr (szLine, ",") 
		If pos > 0 Then
			szLine = Trim (Left (szLine, pos - 1))
		End If
	Else
		szFile = strTarg
		szLine = ""
	End If
	If InStr (1,szFile, ":") = 2 Or Left (szFile, 2) = "\\" Then
	Else
		szFile = szPa & szFile
	End If

If Len(szLine) > 0 Then
		szLine = " -Y=" & szLine
	End If
	Shell "sakura.exe" & " " & szFile & szLine
	Exit Sub

er1:

szPa = ""
	Resume Next

szPa = "" 
	Resume 11

End Sub

Public Function IsFileName (strFile As String) As Boolean 
	IsFileName = False
	If (Left (strFile, 2) = "\\") Then 
		IsFileName = True
	Else
		If ((Left(strFile, 1) >= "A") And (Left (strFile, 1) <= "Z")) Or ((Left(strFile.1) >= "a") And (Left (strFile, 1) <= "z")) Then 
			If (Mid(strFile, 2, 1) = ":") then
				IsFileName = True
			End If
		Else
			If (Left(strFile, 1) >= ".") Then
				IsFileName = True
			End If
		End If
	End If 
End Function

Function DECODEURL (s As String) As String
	On Error GoTo 1
	With CreateObject("ScriptControl") 
		Language = "JScript"
		DECODEURL = CodeObject.decodeURI (s)
	End With

Exit Function

Function RegSch (strTarget As String, strPat As String,Optional RSTART As Integer, Optional RLENGTH As Integer) As String
	Dim Match, Matches
	Dim ret As String

RSTART = 0
	Set RE CreateObject("VBScript.RegExp")
	With RE
		.Pattern = strPat
		.IgnoreCase = True
		.Global = False
	End With
	Set Matches = RE.Execute (strTarget)
	For Each Match In Matches
		RegSch = Match.Value
		RSTART = Match.FirstIndex
		RLENGTH = Match.Length
	Next
End Function

Sub 目次作成()
	Dim n As Integer

On Error GoTo erx

Worksheets.Add before:=Sheets (1)
	Worksheets (1).Name = "目次
	Worksheets (1).Activate
	For n 2 To Worksheets.Count
		Worksheets (n).Name = Replace (Worksheets (n).Name,"(", "〈",,,vbTextCompare)
		Worksheets (n).Name = Replace (Worksheets (n).Name,")", "〉",,,vbTextCompare)
		Worksheets (n).Name = Replace (Worksheets (n).Name," ","_",,,vbTextCompare)
		ActiveSheet.Hyperlinks.Add Anchor:= Worksheets (1).Cells (n + 1, 2),Address:="", SubAddress:=Worksheets (n).Name & "!A1", TextToDisplay:=Worksheets (n).Name
	Next
	End
erx:
	If Err 1004 Then
		Application.DisplayAlerts = False
		Worksheets(1).Delete
		Application.DisplayAlerts = True
		Worksheets("目次").Move before:=Sheets (1)
		Resume Next
	End If
End Sub

Function safename (szName As String)
	safename = szName
	safename = Replace ("(", "〈", , , vbTextCompare)
	safename = Replace (")", "〉", , , vbTextCompare)
	safename = Replace (" ", "_", , , vbTextCompare)
	safename = Replace (",", "_", , , vbTextCompare)
	safename = Replace (";", "_", , , vbTextCompare)
	safename = Replace (Chr(9), "_", , , vbTextCompare)
End Function

Sub シート並べ替え()
	For i =Sheets.Count To 2 Step -1 
		For j=i To 2 Step -1
			If Sheets (j).Name < Sheets (j- 1).Name Then
				Sheets (j).Activate
				Sheets (j).Move before:=Sheets (j - 1)
			End If
		NEXT
	next
end sub

Public Function bakfind (pat As String, ByVal s1 As String) As Integer 
	For bakfind = Len (s1) -Len (pat) + 1 To 1 Step -1 
		If Mid(s1, bakfind, Len (pat)) = pat Then GoTo 11
	Next
11:
End Function

Public Sub 空欄補完()
	Dim ctop As Long 
	dim cleft As Long
	Dim cbottom As Long
	Dim cright As Long 
	
	With Selection
		ctop = Cells (1). Row
		cleft = Cells (1). Column
		cbottom =Cells(.Cells. Count). Row
		cright =Cells (.Cells. Count). Column
	End With 
	For colp =cleft To cright 
		For rowpp =ctop To cbottom 
			If Cells (rowpp, colp). Formula = "" Then 
				If rowpp > ctop Then 
					gof = 1 
					If (colp<>cleft) Then 
						For x =colp-1 To cleft Step -1
							If Cells (rowpp, x) <> Cells (rowpp -1, x) Then_ gof = 0
						Next
					End If
					If gof <> 0 Then 
						Cells (rowpp, colp) = Cells (rowpp -1. colp).Value
					End If
				End If
			End If
		Next
	Next
End Sub

Public Function ConcatSep (rng As Range, Optional sep As String = vbLf, Optional pre As String = "", Optional sur As String = "") As String
	Dim nSel Count As Integer
	nSelCount = rng. Cells. Count

For Each cel In rng. Cells
		If (nSelCount <> rng. Cells. Count) And (nRow <> cel. Row) Then
			ConcatSep ConcatSep & pre 
		End If
		ConcatSep ConcatSep & cel. Value
		nSelCount = nSelCount-1
		If (nSel Count > 0) Then
			ConcatSep =ConcatSep & sep 
		End If
		nRow =cel. Row
	Next
	ConcatSep =ConcatSep & sur
End Function

Sub 自動結合(AMode As Integer)
	Dim rg As Range
	cTopa =ActiveCell.Cells. Row
	clefta =ActiveCell.Cells. Column
	cbottom =Selection (Selection. Count).Row
	cright =Selection (Selection. Count).Column

For cleft= clefta To cright
		For ctop=  cTopa To cbottom
 ;
  ;
  ;
  ;

Sub 複数検索マーク ()
	Dim sFind As Variant
	Dim RSTART As Integer 
	Dim RLENGTH As Integer
	Dim sTargP As String
	If Selection.Cells.Count < 1 Then
		End
	End If
	MultiSearch.Show
	If Not (MultiSearch.CmdOK.Cancel) Then
		sFindAll = Replace (MultiSearch.TextBox1, Chr(13), "")
		sFind = Split (sFindAll, Chr(10))
		For Each cel In Selection.Cells
			For Each sTarg In sFind
				sTargP = sTarg
				If Len(sTarg) > 0 Then 
					RLENGTH = Len (sTarg)
					If UBound (sFind) = 0 Then
						ss = RegSch (cel.Text, sTargP, RSTART, RLENGTH) 
						If Len (ss) > 0 Then RSTART = RSTART + 1
					Else 
						RSTART = InStr (cel, sTarg)
					End If
					If RSTART > 0 Then
						If cel.Formula = cel.Text Then 
							Debug.Print sTarg
							cel.Characters (Start:=RSTART, Length:= RLENGTH).Font.FontStyle = "太字" 
							cel.Characters (Start:=RSTART, Length:= RLENGTH).Font.Color = -16776961

Else 
						End If
					End If
				End If
			Next
		Next
	End If
	Unload MultiSearch
End Sub

Public Function TableFind (tb As String, scName As String, scValue As String, tgName As String, Optional bk As String = "".Optional sh As String = "")
	On Error GoTo lERR
	toprow = Workbooks (bk).Sheets (sh).ListObjects (tb).ListColumns (scName).DataBodyRange.Row
	FindRow = Workbooks (bk).Sheets (sh).ListObjects (tb).ListColumns (scName).DataBodyRange.Find (scValue, lookat:=xlWhole).Row toprow + 1
	TableFind = Workbooks (bk).Sheets (sh).ListObjects (tb).ListColumns (tgName).DataBodyRange (FindRow)
	Exit Function

lERR:
	TableFind = "-"
End Function

Sub 縮小して全体を表示()
	With Selection
		.HorizontalAlignment = xlGeneral
		.VerticalAlignment = xlBottom 
		.WrapText = False
		.Orientation = 0
		.AddIndent False
		.IndentLevel = 0 
		.ShrinkToFit = True
		.ReadingOrder = xIContext
		.MergeCells =False
	End With
End Sub
End Sub

Sub 罫線縦中抜き()

Selection. Borders (xlInsideVertical). LineStyle = xlNone

End Sub 
Sub 罫線横中抜き()

Selection. Borders (xlInsideHorizontal). LineStyle = xlNone

End Sub

だめんずAWK'er (the men's awker)

はじめに

2024年4月22日月曜日

諸事情により一時公開。見ないふりしてくれ。