エクセル小僧：離散した複数のセル範囲に印刷範囲を設定：崖の上のジョージ：So-netブログ

	ブログをはじめるログイン

エクセル小僧：離散した複数のセル範囲に印刷範囲を設定　[コンピューター] [編集]

エクセルのワークシートで、離散した複数のセル範囲にマクロで

印刷範囲を設定する方法を紹介します。

マクロ(VBA)で、印刷範囲を設定するには、

ActiveSheet.PageSetup.PrintArea = "$A$4:$B$5,$D$4:$E$5"

のように、PrintAreaに印刷するセル範囲をカンマ(,)で区切って設定しますが、
セル範囲を示す文字列は、255文字以内である必要があります。多数のセル範囲が
ある場合、255文字を超えてしまうので、各セル範囲に短い名前を定義することにします。

エクセルの名前には、以下のルールがあります。

・使える文字 … 平仮名・カタカナ・漢字・英字・アンダーバー(_)・円記号(\)
・名前の先頭に数字は使えません。
・1文字利用でのC,c,R,cは使えません。
・セル番地も使えません（例：a1)
・スペースは使えない
・半角で数えて255文字まで
・大文字と小文字は区別されない

そこで、次のような名前を付けることにします。

・使用する文字：半角英大文字(A, B, D-Q, S-Z), 半角カタカナ(ア-ン,ァ-ッ）の79文字
・各セル範囲に1, 2, --- と番号を振り、番号を10進→79進変換し、上記の79文字をあてはめる。
  例：1→B, 2→D, --- 78→ッ, 79→BA

ワークシート上の、次のセル範囲を印刷範囲として設定するマクロのコードを以下に示します。
  A1:B2, D1:E2, A4:B5, D4:B5, A7:B8, ---

【マクロ１：メイン】

Sub myMPageAdd1()
'
' myMPageAdd1 Macro
'
Dim i As Long
Dim j As Long
Dim n As Long
Dim LastLine1 As Long
Dim myCell1 As String
Dim myCellName1 As String ' 名前
Dim chkActiveWorkbook As Workbook
'
Set chkActiveWorkbook = ThisWorkbook
myCell1 = "" ' 初期化
n = 1 ' 初期化
LastLine1 = 1 + (3 * 54)
For i = 1 To LastLine1 Step 3
  For j = 0 To 1 Step 1
    myCellName1 = "" & myFTenTo79(n) ' セル範囲につける名前
    Debug.Print "myFTenTo79(" & n & ")=" & myFTenTo79(n)
    n = n + 1
    ' もし、既に名前があるなら、削除
    If chkNames(chkActiveWorkbook, myCellName1) Then
      Application.Names.Item(myCellName1).Delete
      Debug.Print "名前「" & myCellName1 & "」を削除"
    End If
    ' セル範囲につける名前を設定
    Select Case j
    Case 0
      Range("$A$" & i & ":$B$" & (i + 1)).Name = myCellName1
      myCell1 = myCell1 & myCellName1 & ","
    Case 1
      Range("$D$" & i & ":$E$" & (i + 1)).Name = myCellName1
      myCell1 = myCell1 & myCellName1
      If i <> LastLine1 Then
        myCell1 = myCell1 & ","
      End If
    End Select
    Debug.Print "myCell1=" & myCell1
    Debug.Print "Len=" & Len(myCell1) ' ここで長さが255文字を超えるとエラーになる
  Next j
Next i
Debug.Print "myCell1=" & myCell1
ActiveSheet.PageSetup.PrintArea = "" ' 印刷範囲をクリア
ActiveSheet.PageSetup.PrintArea = myCell1 ' 印刷範囲を設定
' Range("A4:B5").Select
' ActiveSheet.PageSetup.PrintArea = "$A$4:$B$5"
' Range("D4:E5").Select
' ActiveSheet.PageSetup.PrintArea = "$A$4:$B$5,$D$4:$E$5"
' Range("A7:B8").Select
' ActiveWindow.SmallScroll Down:=-12
End Sub

【関数１：名前定義の存在を確認】

'名前定義が存在すれば True 、存在しない場合は False
Function chkNames(chkActiveWorkbook As Workbook, prm_Name As String) As Boolean
    Dim n As Name
    chkNames = False
    For Each n In chkActiveWorkbook.Names
        If n.Name = prm_Name Then
            chkNames = True
            Exit For
        End If
    Next
End Function

【関数２：番号を名前の文字列に変換】

' 10進数→79進数文字列変換
Function myFTenTo79(num1 As Long) As String
  Dim Amari As Long
  Dim shou1 As Long
  Dim Kisuu1 As Long
  Dim str1 As String
  Dim chr1(79) As Variant
  Dim i As Long
  Dim j As Long
  Debug.Print "--- myFTenTo79(start) ---"
  Kisuu1 = 79
  ' CとRは、単独で名前に使えない
  ' A(65)-B(66)
  For i = 0 To 1
    chr1(i) = Chr(65 + i)
  Next i
  ' D(68)-Q(81)
  For i = 2 To 15
    chr1(i) = Chr(66 + i)
  Next i
  ' S(83)-Z(90)
  For i = 16 To 23
    chr1(i) = Chr(67 + i)
  Next i
  ' ｱ(177)-ﾜ(220)
  For i = 24 To 67
    chr1(i) = Chr(153 + i)
  Next i
  ' ｦ(166)
  chr1(68) = Chr(166)
  ' ﾝ(221)
  chr1(69) = Chr(221)
  ' ｧ(167)-ｯ(175)
  For i = 70 To 78
    chr1(i) = Chr(97 + i)
  Next i
  shou1 = num1
  str1 = ""
  While shou1 > 0
    Amari1 = shou1 Mod Kisuu1
    str1 = str1 & chr1(Amari1)
    shou1 = Int(shou1 / Kisuu1)
    ' Debug.Print "num1=" & num1 & " Amari1=" & Amari1 & " str1=" & str1
  Wend
  ' Debug.Print "StrReverse(str1)=" & StrReverse(str1)
  myFTenTo79 = StrReverse(str1)
End Function