26.4.13
重複確認
'A2とA3を比較
'A2とA4を比較
'A2とA5を比較
'・・・
'A3とA4を比較
'A3とA5を比較
'A3とA6を比較
Sub 重複()
Dim irow As Long
Dim irow2 As Long
For irow = 2 To 11
For irow2 = irow + 1 To 11 'この考え方ポイント
If Cells(irow, "A") = Cells(irow2, "A") Then
Cells(irow, "A").Interior.Color = 255
Cells(irow2, "A").Interior.Color = 255
End If
Next irow2
Next irow
End Sub
Sub 重複2()
Dim irow3 As Long
For irow3 = 2 To 11
If WorksheetFunction.CountIf(Range("A2:A11"), Cells(irow3, "A")) > 1 Then
'カウイントイフ使う方法
Cells(irow3, "A").Interior.Color = 255
End If
Next irow3
End Sub
26.3.14
Forで回す(カウンタ) か 変数=変数+1
(悪い例)
For irow = 3 To 50 Step 4 '4行ずつ
For j = 0 To 11
Range(Cells(irow, "A"), Cells(irow + 3, "A")) = ngp(j)
'4行ずつ代入
Next j
Next irow
(良い例)
For irow = 3 To 50 Step 4 '4行ずつ
Range(Cells(irow, "A"), Cells(irow + 3, "A")).Value = ngp(j) '4行ずつ代入
j = j + 1
Next irow
25.3.17 新着
Private Sub Worksheet_Change(ByVal Target As Range)
'これはシートモジュールに書いてください
If Intersect(Target, Range("A1")) Is Nothing Then
'セルのA1が変わったら
Exit Sub
Else
On Error GoTo err1
'エラーになったら err1へ飛びます
ActiveSheet.name = Range("A1") & Range("B1")
'セルA1とB1の値をシート名に
Exit Sub
err1:
MsgBox "その名前は使用できません"
MsgBox "既に同じ名前のシートが存在するか、シート名に使えない記号が含まれている可能性があります"
End If
End Sub
25・2・7 新着2本
Sub シートコピー() 'アクティブシートをコピー シート名の初期値は 日付6桁表示
Dim shname As Variant '変数定義
Dim ngp As String '変数定義
ngp = Format(Date, "ge") & Format(Date, "mm") & Format(Date, "dd") '今日の年月日 シリアル値から年月日を結合
'このFormat関数の使い方覚えておくと便利
MsgBox "シートコピーします"
shname = InputBox("シート名を入力してください", , ngp) '変数をインプットボックスから 初期値は本日を6ケタ表示
ActiveSheet.Copy After:=ActiveSheet 'アクティブシートをコピーして後に挿入
'この時点であくちぶしーとはコピー後
ActiveSheet.Name = shname 'シート名変更
End Sub
Sub 選択範囲外枠()
With Selection
.Clear 'いったんクリア
.Borders(xlDiagonalDown).LineStyle = xlNone '右下がり斜め線ひかない
.Borders(xlDiagonalUp).LineStyle = xlNone '右上がり斜め線ひかない
.Borders(xlEdgeLeft).LineStyle = xlContinuous '左辺引く
.Borders(xlEdgeTop).LineStyle = xlContinuous '上辺引く
.Borders(xlEdgeBottom).LineStyle = xlContinuous '下辺引く
.Borders(xlEdgeRight).LineStyle = xlContinuous '右辺引く
.Borders(xlInsideVertical).LineStyle = xlNone '内側垂直線ひかない
.Borders(xlInsideHorizontal).LineStyle = xlNone '内側水平線ひかない
End With
End Sub
Sub 値の入替え()
'インプットボックスで入力した値ここではセルのアドレスを指定 ここではA1とA3
'入替えます
Dim dai1 As Range
Dim dai2 As Range
Dim buf1 As Variant
Dim buf2 As Variant
Set dai1 = Application.InputBox(Prompt:="第1セル", Type:=8) 'セルのアドレス第1
Set dai2 = Application.InputBox(Prompt:="第2セル", Type:=8) 'セルのアドレス第2
buf1 = dai2 'ここで変数へ
buf2 = dai1 'ここで変数へ
Range("A1") = buf1 ' セルを指定 ここではA1
Range("A3") = buf2 ' セルを指定 ここではA3
End Sub
Sub 条件に合致した行全体をコピー() ’C列に「1」と入力されていたら・・・
Dim irow As Long
Dim Lrow1 As Long 'コピー元シートの最終行
Dim Lrow2 As Long 'コピー先シートの最終行(貼付行)
Lrow1 = Worksheets("コピー元").Cells(Rows.Count, "C").End(xlUp).Row ’列は任意
Lrow2 = Worksheets("コピー先").Cells(Rows.Count, "A").End(xlUp).Row ’列は任意
For irow = 8 To Lrow1 'コピー元の任意の列 上から順番に
If Worksheets("コピー元").Cells(irow, "C") = 1 Then '「1」と入力されていたら
Worksheets("コピー先").Range(Worksheets("コピー先").Cells(Lrow2 + 1, "A"), Worksheets("コピー先").Cells(Lrow2 + 1, "R")).Value _
= Worksheets("コピー元").Range(Worksheets("コピー元").Cells(irow, "A"), Worksheets("コピー元").Cells(irow, "R")).Value
'行全体をコピー元の2行目以降に貼り付けていく
Lrow2 = Lrow2 + 1 '貼付行の更新
End If
Next irow
End Sub
’ポイント1 シート間のやり取りなので、シート名が必要
’範囲の設定後 valueで締める
Sub 行削除()
'インプットボックスへ入力した列番号を下からみていき0なら
'行ごと削除します
Dim irow As Long '行をみていく
Dim col As String '列
Dim Lrow As Long '最終行
col = InputBox("対象となる列は?", "0の行削除", "A") '初期はA列
Lrow = Cells(Rows.Count, "col").End(xlUp).Row
For irow = Lrow To 1 Step -1 '下からみていく
If Cells(irow, "col") = 0 Then 'そのセルが0なら
Cells(irow, "col").EntireRow.Delete '行全体削除
End If
Next irow
End Sub
印刷 |
カウンタを利用した印刷 |
Sub 印刷6部() Dim ct As Long For ct = 1 To 12 Step 2 '6部印刷したい Cells(3, "B") = ct '変数にしてB3に代入 ActiveSheet.PrintOut Next ct End Sub |