●メニューへ ●単福へ ●自動車の維持費をシミュレーション ●InDesign JavaScript ノート

マクロ／A列が同じものを見つける


Sub 合体()
    Dim L, C, OldL, OldC2 As Integer
    Dim oldvalue As String
    L = 2 '初期値
    OldL = 1
    oldvalue = Cells(1, 1)
    Do While Cells(L + 1, 1).Value <> ""
        If oldvalue = Cells(L, 1).Value Then
            C = 2
            OldC2 = 2
            '空いているところを見つける
            Do While Cells(OldL, OldC2).Value <> ""
                OldC2 = OldC2 + 1
            Loop
            Do While Cells(L, C).Value <> ""
                Cells(OldL, OldC2).Value = Cells(L, C).Value
                OldC2 = OldC2 + 1
                C = C + 1
            Loop
        Else
            oldvalue = Cells(L, 1)
            OldL = L
        End If
        L = L + 1
    Loop
End Sub


TOPへ


マクロ／かぶり削除


Sub かぶり削除()
    'Application.CutCopyMode = False
    'Selection.Delete Shift:=xlUp
    Dim L As Integer
    L = 414 '初期値
    Do While L > 1
        'MsgBox Cells(L, 2).Value
        If Cells(L, 2).Value = Cells(L - 1, 2).Value Then
            'Cells(L - 1, 9).Value = Cells(L, 8).Value
            Rows(L).Delete Shift:=xlUp
        End If
        L = L - 1
    Loop
End Sub


TOPへ


マクロ／サンプル


Sub 画像名大01()
	Dim N, T As Integer
	Dim buf, Head As String
	T = 51
	For T = 51 To 55
		If T = 51 Then
			Head = "大:"
		ElseIf T = 52 Then
			Head = "小:"
		ElseIf T = 53 Then
			Head = "サブ1:"
		ElseIf T = 54 Then
			Head = "サブ2:"
		ElseIf T = 55 Then
			Head = "サブ3:"
		End If
		For N = 2 To 525
			'MsgBox (Cells(N, T))
			If Str(Cells(N, T)) = "0" Then
				'MsgBox (Str(N) + "/" + Str(T))
			ElseIf Cells(N, T) = 0 Then
			
			Else
				Cells(N, T) = Head + Str(Cells(N, T)) + ".psd"
			End If
		Next
	Next

End Sub


TOPへ


マクロ／ボタンを付ける


表示
ツールバー
フォームでボタンツールを選択して
表上でドラッグする。

すでに作ってあるマクロを登録すればOK

右クリックでマクロを登録する事もできる。


TOPへ


マクロ／マクロの作り方


ツールメニュー
=>マクロ...

マクロ名に名前を入力
マクロの保存先は
すべてのブックか作業中のブックか選ぶ

作成ボタンをクリックすると作成できる


TOPへ


マクロ／合体FG


FとGの項目を合体
Sub 合体FG()
	Dim N As Integer
	Dim buf As String
	For N = 1 To 525
		If Cells(N, 6) = "" Then
			Cells(N, 6) = Cells(N, 7)
		ElseIf Cells(N, 7) = "" Then
			Cells(N, 6) = Cells(N, 6)
		Else
			Cells(N, 6) = Cells(N, 6) + "<br>" + Cells(N, 7)
		End If
	Next
End Sub

A=1
B=2
C=3
D=4
E=5
F=6
G=7
H=8
I=9
J=10
K=11
L=12
M=13
N=14
O=15
P=16
Q=17
R=18
S=19
T=20
U=21
V=22
W=23
X=24
Y=25
Z=26


TOPへ


マクロ／合体FH


FとHの項目を合体
Sub 合体FH()
	Dim N As Integer
	Dim buf As String
	For N = 1 To 525
		If Cells(N, 6) = "" Then
			Cells(N, 6) = Cells(N, 8)
		ElseIf Cells(N, 8) = "" Then
			Cells(N, 6) = Cells(N, 6)
		Else
			Cells(N, 6) = Cells(N, 6) + "・" + Cells(N, 8)
		End If
	Next
End Sub


TOPへ


マクロ／値に応じて色付け


Sub setcolor()
    Dim L As Integer
    Dim goukei As Long
    L = 1 '初期値
    Do While Cells(L + 1, 1).Value <> ""
        If IsNumeric(Cells(L, 5)) Then
            If Cells(L, 5) < 10 Then
                Cells(L, 5).Interior.ColorIndex = xlNone
            ElseIf 9 < Cells(L, 5) And Cells(L, 5) < 20 Then
                Cells(L, 5).Interior.ColorIndex = 36
                'Cells(L, 5).Interior.Pattern = xlSolid
                'Cells(L, 5).Interior.PatternColorIndex = xlAutomatic
            ElseIf 19 < Cells(L, 5) And Cells(L, 5) < 30 Then
                Cells(L, 5).Interior.ColorIndex = 6
                'Cells(L, 5).Interior.Pattern = xlSolid
                'Cells(L, 5).Interior.PatternColorIndex = xlAutomatic
            ElseIf 29 < Cells(L, 5) And Cells(L, 5) < 40 Then
                Cells(L, 5).Interior.ColorIndex = 44
                'Cells(L, 5).Interior.Pattern = xlSolid
                'Cells(L, 5).Interior.PatternColorIndex = xlAutomatic
            ElseIf 39 < Cells(L, 5) And Cells(L, 5) < 100 Then
                Cells(L, 5).Interior.ColorIndex = 45
                'Cells(L, 5).Interior.Pattern = xlSolid
                'Cells(L, 5).Interior.PatternColorIndex = xlAutomatic
            End If
        Else
                Cells(L, 5).Interior.ColorIndex = xlNone
        End If
        L = L + 1
    Loop
End Sub


TOPへ


マクロ／同じで無いものに印


Sub 同じの外す()
	Dim N, T As Integer
	Dim buf1, buf2, buf3 As String
		For N = 2 To 5100
			buf1 = Left(Cells(N - 1, 2), 4)
			buf2 = Left(Cells(N, 2), 4)
			buf3 = Left(Cells(N + 1, 2), 4)
			If buf2 <> buf1 And buf2 <> buf3 Then
				Cells(N, 2) = "同じでない：" + Cells(N, 2)
			End If
		Next
End Sub


TOPへ


マクロ／同じのに印


Sub 同じのに印()
	Dim N, T As Integer
	Dim buf1, buf2, buf3 As String
		For N = 2 To 5100
			'buf1 = Left(Cells(N - 1, 3), 5)
			'buf2 = Left(Cells(N, 3), 5)
			buf1 = Cells(N - 1, 3)
			buf2 = Cells(N, 3)
			If buf2 = buf1 Then
				'Cells(N - 1, 1) = "▲部分一致"
				'Cells(N, 1) = "▲部分一致"
				Cells(N - 1, 1) = "■完全一致"
				Cells(N, 1) = "■完全一致"
			End If
		Next
End Sub


TOPへ


マクロ／入力ボックスを出す


Sub 入力ボックスを出す()
    Dim N As Integer
    N = Application.InputBox(prompt:="入力", Title:="タイトル", Default:=1, Type:=1)
    Cells(1, 1).Value = N
End Sub


Type引数の値
0数式
1数値
2文字列
4trueまたはfalse
8セル参照
16エラー値
64数値配列


TOPへ


マクロ／文字列を区切る


宮崎産　黒毛和牛　こま切れ
みたいな文字列を最初の"　"（全角スペース）で区切ります。


mystr = Cells(L, 1).Value
num = InStr(mystr, "　")
Lstr = Left(mystr, num - 1)
Rstr = Mid(mystr, num + 1)
If Rstr = "" Then
      Lstr = Rstr
      Rstr = ""
End If
Cells(L, 2).Value = Lstr
Cells(L, 3).Value = Rstr


TOPへ


マクロ／文字列を区切る


宮崎産　黒毛和牛　こま切れ
みたいな文字列を最初の"　"（全角スペース）で区切ります。


mystr = Cells(L, 1).Value
num = InStr(mystr, "　")
If num = 0 Then
    Lstr = ""
     Rstr = mystr
Else
     Lstr = Left(mystr, num - 1)
     Rstr = Mid(mystr, num + 1)
End If
Cells(L, 2).Value = Lstr
Cells(L, 3).Value = Rstr


TOPへ


マクロ機能／シートを選択する


Sheets("step2").Select


TOPへ


マクロ機能／シートを増やす


シートを増やす

元の名前を取っておかないと、元シートのデータを参照する事ができなくなる

    motoSheet = ActiveSheet.Name
    Sheets.Add
    ActiveSheet.Name = "step2"
    
    For C = 1 To 45
        Sheets("step2").Cells(C).ColumnWidth = Sheets(motoSheet).Cells(C).ColumnWidth
        Sheets("step2").Cells(C).NumberFormatLocal = Sheets(motoSheet).Cells(C).NumberFormatLocal
        Sheets("step2").Cells(C).VerticalAlignment = Sheets(motoSheet).Cells(C).VerticalAlignment
    Next


TOPへ


マクロ機能／セルが空なら


Sub セルが空なら()
    If IsEmpty(Cells(2, 1).Value) = True Then
        Cells(2, 1).Interior.ColorIndex = 6
    End If
End Sub


TOPへ


マクロ機能／セルが数値なら


Sub セルが数値なら()
    If IsNumeric(Cells(3, 1).Value) = True Then
        Cells(3, 1).Interior.ColorIndex = 6
    End If
End Sub


TOPへ


マクロ機能／セルフォーマットを文字列に


Cells(N, 2).NumberFormatLocal = "@"


TOPへ


マクロ機能／テキスト出力


下記のようにテキスト保存すると
Macintosh HDのexcelフォルダに保存されます。
Windowsの場合はC:\excel\というように指定します。
下記baikaは変数です。

N = FreeFile
Open "Macintosh HD:excel:" + "売価.txt" For Output As #N
Print #N, baika
Close #N


TOPへ


マクロ機能／行を増やす


行を増やす

Rows(L).Insert Shift:=xlDown


TOPへ


マクロ機能／四捨五入


Sub 四捨五入()
    Cells(1, 1).Value = Application.WorksheetFunction.Round(Cells(1, 2).Value, 3)
End Sub


Application.WorksheetFunction.Round(Cells(1, 2).Value, ●)

●は四捨五入する少数の桁数。

切り上げ
Application.WorksheetFunction.RoundUP(Cells(1, 2).Value, ●)

切り捨て
Application.WorksheetFunction.RoundDown(Cells(1, 2).Value, ●)


TOPへ


マクロ機能／特定のセルを含む表に処理を行う


CurrentRegionは空白行から空白行までの処理を行う

Sub A1を含む表に処理をする()
    Dim i, rowCount As Integer
    rowCount = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
    For i = 1 To rowCount
        ActiveSheet.Range("A1").CurrentRegion.Rows(i).Value = i
    Next
End Sub


TOPへ


マクロ機能／名前をつけて保存


（保存されているフォルダにtest.xlsで保存）

Mac
Sub 名前をつけて保存()
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & ":test.xls"
End Sub

Win
Sub 名前をつけて保存()
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\test.xls"
End Sub


TOPへ


マクロ機能／列の幅を変更


Sub 列の幅()
    ActiveSheet.Columns(1).ColumnWidth = 3
End Sub


TOPへ


マクロ文法／Do Loop


Do Loopで行数分処理を行います。
下の例ではA列の値がなくなるまで処理をします。

    L = 2 '初期値
    Do While Cells(L + 1, 1).Value <> ""
         'イロイロ処理をする
        L = L + 1
    Loop


TOPへ


マクロ文法／Do Loop空行が20連続でSTOP


    loopendcount = 0
    Do While loopendcount < 20
        If Sheets(motoSheet).Cells(L + 1, 7).Value = "" Then
            loopendcount = loopendcount + 1
        Else
            loopendcount = 0
        End If
        '処理をかく
        L = L + 1
    Loop


TOPへ


マクロ文法／For Next


下記はStep 2を指定しているので1つ飛ばしで実行する。

        For C = 5 To MaxCellCount Step 2 '売価に色付け（グリーン）
            '処理
        Next


TOPへ


マクロ文法／InStr文字の検索


long = InStr([start, ]targetstring, serchstring[, compare])

結果は文字の存在した位置が数値で返ってくる。
文字がなかったら0


TOPへ


マクロ文法／Left


左から5文字とり出します。
buf2 = Left(Cells(N, 3), 5)


TOPへ


マクロ文法／Mid


mystr = "0123456789" 

'2文字目から5文字分12345が取り出せる 
midStr = Mid(mystr, 2, 5) 
MsgBox (midStr)


TOPへ


マクロ文法／Split文字を分割する


Splitで文字を分割できます。
下記は全角スペースで分割

mystr = "たけうち　とおる" 
myArray = Split(mystr, "　") 

'名字 
MsgBox (myArray(0)) 
'名前 
MsgBox (myArray(1))


TOPへ


マクロ文法／if elseif end if


If T = 51 Then
	Head = "大:"
ElseIf T = 52 Then
	Head = "小:"
ElseIf T = 53 Then
	Head = "サブ1:"
ElseIf T = 54 Then
	Head = "サブ2:"
ElseIf T = 55 Then
	Head = "サブ3:"
End If


TOPへ


マクロ文法／テキストをフォーマットする


Format(Cells(L, C).Value, "##,###")


TOPへ


メモ／行と列を入れ替える


入れ替えたい範囲をコピーし
貼付け時に
編集メニューから形式を指定して貼付けを選ぶ
行列を入れ替えるにチェックを入れて
貼り付け


TOPへ