昔に作っったVBA（今は動くか不明）

function.vba

VBA：【VBA関数いろいろ】
Public Sub 選択範囲マッチング()
'************************************************************
'*　 選択範囲マッチング
'*
'*　 第一引数：無し
'*　 戻り値 ：無し
'*　 -------------使用方法
'*　適当なＢｏｏｋのマッチング対象としたい範囲を選択し
'*　 このModuleを実行する。
'*　マッチング対象の元は基本ツール.xls:汎用ＢＯＯＫマッチングシートの
'*　 Ａ列３行目からを元にする
'************************************************************'
Dim t%, y%, cc%
Dim Yok$
Dim Cr, ken

Cr = Chr(13)
Bo = ActiveWorkbook.Name
Sh = ActiveSheet.Name
t% = 3
y% = 1
ken = 0

MsgBox("基本ツール.xls:汎用ＢＯＯＫマッチングシートの"& Cr& _
　　　　"[マッチング対象データ（A)+]をマッチング元にし" & Cr& _
　　　 "存在したときはFONTを赤にする")
ret = MsgBox("セルを塗り潰しを有効にする",vbYesNo,"選択範囲マッチング")
If (ret = vbYes) Then
　 Sel = 999
Else
　 Sel = 0
End If
rrt = MsgBox("完全に一致したものだけを検索",vbYesNo,"選択範囲マッチング")
If (rrt = vbYes) Then
　 ken = 999
Else
　 ken = 0
End If

Worksheets(Sh).Activate

'アクティブウィンドウのワークシートで選択されているセル範囲の参照を表示
Add = ActiveWindow.RangeSelection.Address
'MsgBox (Add)
'MsgBox (Bo)
'MsgBox (Sh)

Set Obj = Workbooks(Bo).Worksheets(Sh)
Set ObjM=Workbooks("基本ツール.xls").Worksheets("汎用ＢＯＯＫマッチング")

Top = Mid(Add, 2, 1)
bb = Asc(Top)
bb = bb - 64
cc% = 0

'基本ツール.xls:汎用ＢＯＯＫマッチングシートの最終行取得
ObjM.Activate
CCC = Cells(Rows.Count, 1).End(xlUp).Row

'汎用対象をアクティブ
Obj.Activate

'検索メイン
'ブランク削除
Do While (ObjM.Cells(t%, y%) = "")
　 t% = t% + 1
　 If (t% > CCC) Then
　　 Exit Do
　 End If
Loop
Do While (1)
　 With Worksheets(Sh).Range(Add)
　　　 If (ken = 999) Then
　　　　 '完全に一致したものだけを検索
　　　　 Set C = .Find(ObjM.Cells(t%, y%),LookIn:=xlValues,LookAt:=xlWhole)
　　　 Else
　　　　 '一部一致したものを検索
　　　　 Set C = .Find(ObjM.Cells(t%, y%), LookIn:=xlValues)
　　　 End If
　　　 If Not C Is Nothing Then
　　　　　 firstAddress = C.Address
　　　　　 Do
　　　　　　　 'c.Interior.Pattern = xlPatternGray50
　　　　　　　 Set C = .FindNext(C)
　　　　　　　 Range(C.Address).Select
　　　　　　　 Selection.Font.ColorIndex = 3
　　　　　　　
　　　　　　　 'セル塗りつぶし-----------------------
　　　　　　　 If (Sel = 999) Then
　　　　　　　　　 With Selection.Interior
　　　　　　　　　 .ColorIndex = 40
　　　　　　　　　 .Pattern = xlSolid
　　　　　　　　　 End With
　　　　　　　 End If
　　　　　　　 '------------------------------------
　　　　　　　
　　　　　　　 If (t% > CCC) Then
　　　　　　　　　 Exit Do
　　　　　　　 End If
　　　　　　　
　　　　　 Loop While Not C Is Nothing And C.Address<>firstAddress
　　　 End If
　 End With
　 cnt = cnt + 1
　 t% = t% + 1
　
　 'ブランクは検索対象から外す
　 Do While (ObjM.Cells(t%, y%) = "")
　　 t% = t% + 1
　　 If (t% > CCC) Then
　　　　 Exit Do
　　 End If
　 Loop
　
　 If (t% > CCC) Then
　　 Exit Do
　 End If

Loop

ret = MsgBox("----------- End ------------",vbSystemModal,"選択範囲マッチング")

End Sub


Public Function 英半角文字⇒英全角文字(henkanMoji$)
'************************************************************
'*　 英半角文字⇒英全角文字（Alphabet）
'*
'*　 第一引数：(i) 調査対象文字列
'*　 戻り値 ：ファイル名
'************************************************************'

　 Dim inMoji$
　 Dim outMiji$

　 '文字列取得
　 inMoji$ = henkanMoji$
　 Call HanZenChenger_Char(1, inMoji$, outMoji$)
　 英半角文字⇒英全角文字 = outMoji$

End Function

Public Function 英全角文字⇒英半角文字(henkanMoji$)
'************************************************************
'*　 英全角文字⇒英半角文字（Alphabet）
'*
'*　 第一引数：(i) 調査対象文字列
'*　 戻り値 ：ファイル名
'************************************************************'

　 Dim inMoji$
　 Dim outMiji$

　 '文字列取得
　 inMoji$ = henkanMoji$
　 Call HanZenChenger_Char(2, inMoji$, outMoji$)
　 英全角文字⇒英半角文字 = outMoji$

End Function

Sub HanZenChenger_Char(henFlg%, inMoji$, outMoji$)
'************************************************************
'*　 半角全角変換（Alphabet）
'*
'*　 第１引数：(in) 1 : 半角文字⇒全角文字
'*　　　　　　　　 2 : 全角文字⇒半角文字
'*　 第２引数：(in) 変換前文字列
'*　 第３引数：(out) 変換後文字列
'*　 戻り値 ：
'************************************************************'

Dim HanTable$, ZenTable$
Dim HenTable1$, HenTable2$
Dim wkChar$
Dim i%
Dim n

　 HanTable$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
　 ZenTable$="ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚ"

　 If henFlg% = 1 Then
　　　 '半角文字⇒全角文字
　　　 HenTable1$ = HanTable$
　　　 HenTable2$ = ZenTable$
　 Else '全角文字⇒半角文字
　　　 HenTable1$ = ZenTable$
　　　 HenTable2$ = HanTable$
　 End If
　
　 wkChar$ = inMoji$

　 For i% = 1 To Len(HenTable1$)
　　　 Do
　　　　　 n = InStr(wkChar$, Mid(HenTable1$, i%, 1))
　　　　　 If n > 0 Then
　　　　　　　 Mid(wkChar$, n, 1) = Mid(HenTable2$, i%, 1)
　　　　　 End If
　　　 Loop Until n = 0
　 Next
　
　 outMoji$ = wkChar$
　
End Sub

Public Function 数半角文字⇒数全角文字(henkanMoji$)
'************************************************************
'*　 数半角文字⇒数全角文字（Number）
'*
'*　 第一引数：(i) 調査対象文字列
'*　 戻り値 ：ファイル名
'************************************************************'

　 Dim inMoji$
　 Dim outMiji$

　 '文字列取得
　 inMoji$ = henkanMoji$
　 Call HanZenChenger_Num(1, inMoji$, outMoji$)
　 数半角文字⇒数全角文字 = outMoji$

End Function

Public Function 数全角文字⇒数半角文字(henkanMoji$)
'************************************************************
'*　 数全角文字⇒数半角文字（Number）
'*
'*　 第一引数：(i) 調査対象文字列
'*　 戻り値 ：ファイル名
'************************************************************'

　 Dim inMoji$
　 Dim outMiji$

　 '文字列取得
　 inMoji$ = henkanMoji$
　 Call HanZenChenger_Num(2, inMoji$, outMoji$)
　 数全角文字⇒数半角文字 = outMoji$

End Function

Sub HanZenChenger_Num(henFlg%, inMoji$, outMoji$)
'************************************************************
'*　 半角全角変換（Number）
'*
'*　 第１引数：(in) 1 : 半角文字⇒全角文字
'*　　　　　　　　 2 : 全角文字⇒半角文字
'*　 第２引数：(in) 変換前文字列
'*　 第３引数：(out) 変換後文字列
'*　 戻り値 ：
'************************************************************'

Dim HanTable$, ZenTable$
Dim HenTable1$, HenTable2$
Dim wkChar$
Dim i%
Dim n

　 HanTable$ = "1234567890"
　 ZenTable$ = "１２３４５６７８９０"

　 If henFlg% = 1 Then
　　　 '半角文字⇒全角文字
　　　 HenTable1$ = HanTable$
　　　 HenTable2$ = ZenTable$
　 Else '全角文字⇒半角文字
　　　 HenTable1$ = ZenTable$
　　　 HenTable2$ = HanTable$
　 End If
　
　 wkChar$ = inMoji$

　 For i% = 1 To Len(HenTable1$)
　　　 Do
　　　　　 n = InStr(wkChar$, Mid(HenTable1$, i%, 1))
　　　　　 If n > 0 Then
　　　　　　　 Mid(wkChar$, n, 1) = Mid(HenTable2$, i%, 1)
　　　　　 End If
　　　 Loop Until n = 0
　 Next
　
　 outMoji$ = wkChar$
　
End Sub

Public Function アスキー変換(str As String)
'-----------------------------------------------------
'- アスキー変換
'-
'-
'-----------------------------------------------------
　 'MsgBox (str)
　 アスキー変換 = Application.Asc(str)

End Function
Public Function アスキーコード取得(str As String)
'-----------------------------------------------------
'- アスキーコード取得
'-
'-
'-----------------------------------------------------
　 'MsgBox (str)
　 アスキーコード取得 = Asc(str)

End Function

Public Function 日付フォーマット変換(da As String)
'
'日付フォーマット変換
'
　 Dim date_c
　
　 date_c = Format(da, "yyyymmdd")
　
　 日付フォーマット変換 = date_c
　
End Function

Public Sub ブランク行挿入()
'-------------------------------------------------------------
'-　指定数分、ブランク行を挿入する
'-
'-　引数１（ユーザー入力）：開始行
'-　引数２（ユーザー入力）：挿入の数
'-　引数３（ユーザー入力）：終了行数
'-------------------------------------------------------------
Dim Blk$, aaX$, kazX$, cntX$
Dim aa%, cnt%, i%
Dim Rt

Rt = Chr(13) '& Chr(10)

MsgBox ("指定数分、ブランク行を挿入します")

aa% = 0
kaz% = 0
cnt% = 0

aaX$ = InputBox("開始行を入力して!")
If (aaX$ <> "") Then
　 aa% = CInt(aaX$)
Else
　 MsgBox ("　　　　 Null" & _
　　　　　 Rt & "------ End ------")
　 End
End If
kazX$ = InputBox("挿入の数")
If (kazX$ <> "") Then
　 kaz% = CInt(kazX$)
Else
　 MsgBox ("　　　　 Null" & Rt & "------ End ------")
　 End
End If
cntX$=InputBox("終了行数を指定して!(挿入後の行数を含めて)")
If (cntX$ <> "") Then
　 cnt% = CInt(cntX$)
Else
　 MsgBox ("　　　　 Null" & Rt & "------ End ------")
　 End
End If

　 Blk$ = aa% & ":" & aa%
　
　 Rows(Blk$).Select
　
　 Do While (i% <> kaz)
　　　 Selection.Insert Shift:=xlDown
　　　 i% = i% + 1
　 Loop
　 i = 0
　
Do While (aa% < cnt%)
　
　 aa% = aa% + kaz + 1
　 Blk$ = aa% & ":" & aa%
　
　 Rows(Blk$).Select
　
　 Do While (i% <> kaz)
　　　 Selection.Insert Shift:=xlDown
　　　 i% = i% + 1
　 Loop
　 i = 0
Loop

End Sub

Public Function GET_STR(BOOK As String, SHEET As String, TATE As Integer,YOKOAs Integer)

'************************************************************
'*　 シートから文字を取得
'*
'*　 第一引数：(i) ＢＯＯＫ名
'*　 第二引数：(i) シート名
'*　 第三引数：(i) 縦位置
'*　 第三引数：(i) 横位置
'*　 戻り値 ：　 文字列
'************************************************************

　 GET_STR = Workbooks(BOOK).Worksheets(SHEET).Cells(0 + TATE, YOKO)

End Function

Public Function SENT_STR(BOOK As String, SHEET As String, TATE As Integer,YOKOAs Integer, str As String)

'************************************************************
'*　 シートに文字を送る
'*
'*　 第一引数：(i) ＢＯＯＫ名
'*　 第二引数：(i) シート名
'*　 第三引数：(i) 縦位置
'*　 第三引数：(i) 横位置
'*　 戻り値 ：　 無
'************************************************************

　 Workbooks(BOOK).Worksheets(SHEET).Cells(0 + TATE, YOKO) = str

End Function

Public Function AREA_CLEAN(sheet_name As String, ichi_s As String, ichi_eAsString)

'************************************************************
'*　 エリアクリア
'*
'*　 第一引数：(i) シート名
'*　第二引数：(i)範囲指定ｔｏｐ(例：Ｃ３からＣ１５００まで）"C3:C1500"
'*　第三引数：(i)範囲指定ｅｎｄ(例：Ｃ３からＣ１５００まで）"C3:C1500"
'*　 戻り値 ：　 無
'************************************************************
　
　 Dim ichi As String
　
　 ichi = ichi_s + ":" + ichi_e
　
　 Sheets(sheet_name).Select
　 Range(ichi).Select
　 Selection.ClearContents
　 Range(ichi_s).Select
　
End Function

Public Function RETU_SORT(sheet_name As String, ichi_s As String, ichi_eAsString)

'************************************************************
'*　 選択列ソート
'*
'*　 第一引数：(i) シート名
'*　第二引数：(i)範囲指定ｔｏｐ(例：Ｃ３からＣ１５００まで）"C3:C1500"
'*　第三引数：(i)範囲指定ｅｎｄ(例：Ｃ３からＣ１５００まで）"C3:C1500"
'*　 戻り値 ：　 無
'************************************************************
　
　 Dim ichi As String
　
　 ichi = ichi_s + ":" + ichi_e
　
　 Sheets(sheet_name).Select
　 'Range("C3:C1500").Select
　 Range(ichi).Select
　 Selection.sort Key1:=Range(ichi_s), Order1:=xlAscending,Header:=xlGuess,_
　　　 OrderCustom:=1, MatchCase:=False,Orientation:=xlTopToBottom,SortMethod _
　　　 :=xlPinYin
　 Range(ichi_s).Select
　
End Function

Public Function open_book()

'************************************************************
'*　 Excel Book open
'*
'*　 第一引数：
'*　 第二引数：
'*　 戻り値 ：
'************************************************************

Dim pass_name As String

　 pass_name = "TOOL"
　
　 ChDir pass_name
　 Workbooks.OpenFileName:="TOOLileload.xls"

End Function
Public Function 文字制限数までSPACE(str_sell As String, max_lengthAsInteger) As String

'************************************************************
'*　 文字制限数までSPACE
'*
'*　 第一引数：(i) 文字列
'*　 第二引数：(i) max文字長
'*　 戻り値 ：　 ブランク付文字列
'************************************************************

　 Dim mk_str As String
　
　 mk_str = str_sell
　 len_cnt = 0
　
　 len_cnt = 半角エリアで全角チェック(str_sell)
　
　 Do While max_length >= len_cnt + 1
　　　 len_cnt = len_cnt + 1
　　　 mk_str = mk_str + " "
　 Loop

　 文字制限数までSPACE = mk_str

End Function
Public Function 半角エリアで全角チェック(str As String)

'************************************************************
'*　 半角エリアで全角チェック
'*
'*　 第一引数：(i) 調査対象文字列
'*　 戻り値 ：　 正常時 = 文字数（ｂｙｔｅ）
'************************************************************

Dim i As Integer
Dim cha As String
Dim code As Integer
Dim ret_cnt As Integer

i = 1
ret_cnt = 0

cha = Mid(str, 1, 1)

　 Do While (1)
　　　 cha = Mid(str, i, 1)
　　　 If (cha = "") Then
　　　　　 Exit Do
　　　 Else
　　　　　 code = Asc(cha)
　　　　　 If (code < 0) Then
　　　　　　　 '全角文字があった場合(ERROR)
　　　　　　　 ret_cnt = 9999
　　　　　　　 str = ""
　　　　　　　 'エラー処理
　　　　　　　 '半角エリアに全角
　　　　　 Else
　　　　　　　 ret_cnt = ret_cnt + 1
　　　　　 End If
　　　 End If
　　　 i = i + 1
　 Loop
'End If


半角エリアで全角チェック = ret_cnt
　
End Function
Public Function 全角エリアで半角チェック(str As String)

'************************************************************
'*　 全角エリアで半角チェック
'*
'*　 第一引数：(i) 調査対象文字列
'*　 戻り値 ：正常時 = 文字数（ｂｙｔｅ）
'************************************************************'　　　　　エラー時= 9999

Dim i As Integer
Dim cha As String
Dim code As Integer
Dim ret_cnt As Integer
Dim Cr

Cr = Chr(13)

i = 1
ret_cnt = 0

'ret = MsgBox("リターンコードは占有バイト数" & Cr & _
'　　　 "エラーの場合は９９９９", vbSystemModal)
　　　 'vbSystemModal
　　　 'vbApplicationModal
　　　
cha = Mid(str, 1, 1)
　
　 Do While (1)
　　　 cha = Mid(str, i, 1)
　　　 If (cha = "") Then
　　　　　 Exit Do
　　　 End If
　　　 code = Asc(cha)
　　　 If (code > 0 And code <> 32) Then
　　　　　 '半角文字があった場合
　　　　　 ret_cnt = 9999
　　　　　 str = ""
　　　　　 'エラー処理
　　　　　 '全角エリアに半角
　　　 Else
　　　　　 If (code <> 32) Then
　　　　　　　 ret_cnt = ret_cnt + 2
　　　　　 Else
　　　　　　　 If (code = 32) Then
　　　　　　　　　 ret_cnt = ret_cnt + 1
　　　　　　　 End If
　　　　　 End If
　　　 End If
　　　 i = i + 1
　 Loop

全角エリアで半角チェック = ret_cnt

　
End Function
Public Function フルパスからファイル名を取得(PathName$)
'************************************************************
'*　 フルパスからファイル名を取得
'*
'*　 第一引数：(i) 調査対象文字列
'*　 戻り値 ：ファイル名
'************************************************************'

Dim PathLen%
Dim CheckStr$
Dim RightStr$
Dim i%, j%

'ﾊﾟｽのﾚﾝｸﾞｽ取得
PathLen% = Len(PathName$)

For i% = 1 To PathLen% Step 1
　 RightStr$ = Right(PathName$, i%)
　 CheckStr$ = Left(RightStr$, 1)
　
　 If CheckStr$ = "" Then
　　 'ﾌｧｲﾙ名の取得
　　 フルパスからファイル名を取得 = Right(PathName$, i% -1)

　　 Exit For
　 End If
Next

End Function

'************************************************************
'*　 A1セルがブランクだったら列を削除
'*　　８００行まで
'*　 第一引数：(i) なし
'*　 戻り値 ：なし
'************************************************************'
Sub ブランクだったら列を削除()

Dim i%, ret1
Dim wkCnt%
Dim ret, ret1X$, Rt

Rt = Chr(13)

'アクティブウィンドウのワークシートで選択されているセル範囲の参照を表示
Add = ActiveWindow.RangeSelection.Address

MsgBox ("選択列がブランクの行を削除します。")
ret = MsgBox("対象は「" & Add & "」です", vbYesNo)

If (ret = vbNo) Then
　 End
End If

'Rangeタイプのスタート位置取得---------------------------S
i = 1
Do While (Mid(Add, i, 1) <> "")
　 If (Mid(Add, i, 1) = ":") Then
　　 i = i - 1
　　 Exit Do
　 End If
　 i = i + 1
Loop
j = 1
Do While (j < i)
　 If (Mid(Add, j + 1, 1) <> "$" And IsNumeric(Mid(Add, j + 1, 1))=False) Then
　　 Top = Top + Mid(Add, j + 1, 1)
　 End If
　 If (Mid(Add, j + 1, 1) <> "$" And IsNumeric(Mid(Add, j + 1, 1))=True) Then
　　 kaz = kaz + Mid(Add, j + 1, 1)
　 End If
　 j = j + 1
Loop
'MsgBox (Top)
'MsgBox (kaz)
'------------------------------------------------------E
'RangeタイプのEND位置取得-------------------------------S
Las = Len(Add)
r = Las
Do While (r > 0)
　 If (Mid(Add, r, 1) <> "$") Then
　　 t = t + 1
　 Else
　　 Exit Do
　 End If
　 r = r - 1
Loop
Last = Mid(Add, r + 1, t)
'MsgBox (Last)
'------------------------------------------------------E

i = kaz
l = Last

If (IsNumeric(l) <> True) Then
MsgBox ("一括の指定はできません" & " : " & Add)
End
End If

Do While (i < l + 1)
　 If (Range(Top & i).Value = "") Then
　　　 Rows(i & ":" & i).Select
　　　 Selection.Delete Shift:=xlUp
　　　 l = l - 1
　 Else
　　 i = i + 1
　 End If
Loop
Range("A1").Select

End Sub

'************************************************************
'*　 指定文字の列を削除
'*　　８００行まで
'*　 第一引数：(aaaa) 指定文字
'*　 戻り値 ：なし
'************************************************************'
Sub 指定文字の列を削除()

Dim i%, ret1, k%
Dim wkCnt%
Dim ret, ret1X$, Rt

Rt = Chr(13)

'アクティブウィンドウのワークシートで選択されているセル範囲の参照を表示
Add = ActiveWindow.RangeSelection.Address

k%=InputBox("選択行の指定桁１文字目が指定した値だったら、その行を削除します｡"_
　　　　　　　 & Chr(13) & "桁を入力して！")
aaaa = InputBox("指定する１文字を入力して！")
ret = MsgBox("対象は「" & Add & "」です", vbYesNo)

If (ret = vbNo) Then
　 End
End If

'Rangeタイプのスタート位置取得---------------------------S
i = 1
Do While (Mid(Add, i, 1) <> "")
　 If (Mid(Add, i, 1) = ":") Then
　　 i = i - 1
　　 Exit Do
　 End If
　 i = i + 1
Loop
j = 1
Do While (j < i)
　 If (Mid(Add, j + 1, 1) <> "$" And IsNumeric(Mid(Add, j + 1, 1))=False) Then
　　 Top = Top + Mid(Add, j + 1, 1)
　 End If
　 If (Mid(Add, j + 1, 1) <> "$" And IsNumeric(Mid(Add, j + 1, 1))=True) Then
　　 kaz = kaz + Mid(Add, j + 1, 1)
　 End If
　 j = j + 1
Loop
'MsgBox (Top)
'MsgBox (kaz)
'------------------------------------------------------E
'RangeタイプのEND位置取得-------------------------------S
Las = Len(Add)
r = Las
Do While (r > 0)
　 If (Mid(Add, r, 1) <> "$") Then
　　 t = t + 1
　 Else
　　 Exit Do
　 End If
　 r = r - 1
Loop
Last = Mid(Add, r + 1, t)
'MsgBox (Last)
'------------------------------------------------------E

i = kaz
l = Last

If (IsNumeric(l) <> True) Then
MsgBox ("一括の指定はできません" & " : " & Add)
End
End If

Do While (i < l + 1)
　 If (Mid(Range(Top & i).Value, k%, 1) = aaaa) Then
　　　 Rows(i & ":" & i).Select
　　　 Selection.Delete Shift:=xlUp
　　　 l = l - 1
　 Else
　　 i = i + 1
　 End If
Loop
Range("A1").Select

End Sub

Public Sub color_get()
'--------------------------------------------------
'--------------シート総なめチェック-----------------
'
'指定したシート枠の中のカラムのカラーが
'薄黄色’のものがあったら別シートに1列にコピーする
'--------------------------------------------------

Dim tate_1%
Dim yoko_1$
Dim tate_2%
Dim yoko_2$, end_retu$
Dim char%, cnt%

'元シート横の列
yoko_1$ = "A"
'コピーシート横の列
yoko_2$ = "A"
'元シート縦の列
tate_1% = 1
'コピーシート縦の列
tate_2% = 1
'横の列カウント
char% = 0
　
MsgBox("シートのセルが薄黄色のセルを次シートに1列でコピーします")
yoko_1$=InputBox("開始する縦の列を入力(アルファベット大文字）")
end_retu$=InputBox("終了する縦の列を入力(アルファベット大文字）")
cnt% = InputBox("対象とする行数を入力（半角数値）")

'横の列’Ｋ’までループ
Do While (yoko_1$ < end_retu$)
　 '縦の列’１５００’までループ
　 Do While (tate_1% < cnt%)
　　　 '4番目のシートのセルが薄黄色だったら
　　　 If (Sheets(1).Range(yoko_1$ & tate_1%).Interior.ColorIndex =36)Then
　　　　　 '7番目のシートの指定したセルにコピー
　　　　　 Sheets(2).Range("A" & tate_2%) =Sheets(1).Range(yoko_1$& tate_1%).Value
　　　　　 '7番目シートのカウントをインクリメント
　　　　　 tate_2% = tate_2% + 1
　　　 End If
　　　 '4番目シートのカウントをインクリメント
　　　 tate_1% = tate_1% + 1
　 Loop
　 '4番目シートのカウントを初期化
　 tate_1% = 1
　
　 char% = char% + 1
　 '横の列をカウント
　 'ｃｈｒを使って数値から文字に変換
　 yoko_1$ = Chr(65 + char%)
Loop
MsgBox ("END")
End Sub


Public Sub 選択範囲取得()
'選択範囲を拾ってくる

'アクティブワークブック＆シート名取得
Bo = ActiveWorkbook.Name
Sh = ActiveSheet.Name

Worksheets(Sh).Activate

'アクティブウィンドウのワークシートで選択されているセル範囲の参照を表示
MsgBox (ActiveWindow.RangeSelection.Address)

End Sub
'************************************************************
'*　 シェル実行（バッチファイル）
'*
'*　 第一引数：(----)
'*　 戻り値 ：なし
'************************************************************'
Public Sub Shell_Run()
ret = Shell("c:dir.bat", vbNormalFocus)
End Sub

'*********************************************************
'セル範囲からスタート位置取得($D$8:$D$21)=>8
'範囲ＡからＺまで
'*********************************************************
Private Function S_Get(Add)
i = 1
Do While (1)
　 If (Mid(Add, i, 1) = ":") Then
　　 S_Get = Mid(Add, 4, i - 4)
　　 Exit Do
　 End If
　 i = i + 1
Loop
End Function
'*********************************************************
'セル範囲からエンド位置取得($D$8:$D$21)=>21
'
'*********************************************************
Private Function E_Get(Add)
i = Len(Add)
Do While (1)
　 If (Mid(Add, i, 1) = "$") Then
　　 E_Get = Mid(Add, i + 1, 5)
　　 Exit Do
　 End If
　 i = i - 1
Loop
End Function