マクロ/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へ
マクロ機能/シートを増やす
シートを増やす
元の名前を取っておかないと、元シートのデータを参照する事ができなくなる
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へ
マクロ機能/テキスト出力
下記のようにテキスト保存すると
Macintosh HDのexcelフォルダに保存されます。
Windowsの場合はC:\excel\というように指定します。
下記baikaは変数です。
N = FreeFile
Open "Macintosh HD:excel:" + "売価.txt" For Output As #N
Print #N, baika
Close #N
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へ
マクロ文法/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へ
マクロ文法/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へ
メモ/行と列を入れ替える
入れ替えたい範囲をコピーし
貼付け時に
編集メニューから形式を指定して貼付けを選ぶ
行列を入れ替えるにチェックを入れて
貼り付け
TOPへ