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行ずつ

        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