• きっかけ
  日本ってどこまで行っても日本だと思いません？
  いや、その海を渡ったら…って話ではなく、仕事の流れが…って事で。
  
  …ああ、デジャブ(^^;;
  
  Excelでもこんな事を考えてVBA作りましたわ(^^;;
  
  
  様は色々な課から統一の様式で情報がまわって来ます。
  それをまとめて管理しているのですが、それぞれの課に対してそれぞれの課の情報をだけを返すとき、一つのエクセルシートだけを返すとそこには他課の情報も載っており、あまりきれいではないなぁ〜と言うのが作成の動機。
  


• 仕組み
  
  • Excelシート
    以下の様なシートを作ったとします。

    見出し	○○課	△△課	□□課	☆☆課
    データ1	1234	5678	9012	3456
    データ2	aaaa	bbbb	cccc	dddd

    
    ここで、課とデータ1〜2は行のタイトル、列のタイトルとして指定されています。
    また、課毎に垂直改ページが挿入されており、印刷をした場合、
    
    

    見出し	○○課
    データ1	1234
    データ2	aaaa

    
    

    見出し	△△課
    データ1	5678
    データ2	bbbb

    　　：
    　　：
    　　：
    
    と印刷される様になっています。
    
    このシートを印刷した時のイメージと同じになるようにそれぞれ保存する事を考えましょう。
    
    
• VBAの記述
  sheet1に作成したシートを改ページイメージで出力します。
  

  Sub outputFile()
      Dim i As Integer
      Dim copyarea, deleteArea As String
      Dim deleteRow As String
      Dim deleteCol As String
      Dim deleteColStart1 As String
      Dim deleteColEnd1 As String
      Dim deleteColStart2 As String
      Dim deleteColEnd2 As String
      Dim deleColNo As Integer
      Dim deleCell1, deleCell2 As String
      
      Call datacopy
      
      ' 初回は改ページから後ろを削除
      deleteArea = sheet1.VPageBreaks(1).Location.Address
      deleColNo = InStr(2, deleteArea, "$")
      deleteCol = Mid(deleteArea, 2, Len(deleteArea) - deleColNo)
      deleteColStart2 = deleteCol
      ActiveSheet.Columns(deleteColStart2 & ":IV").Delete
      
      deleteArea = sheet1.PageSetup.PrintTitleColumns
      deleColNo = InStrRev(deleteArea, "$")
      deleteCol = Right(deleteArea, Len(deleteArea) - deleColNo)
      deleteColStart1 = colPlus1(deleteCol)
      
      For i = 2 To CInt(sheet1.VPageBreaks.Count)
          Call fileSave
          Call datacopy
          ' 二回目以降は前回の位置-1と、印刷領域の一つ次からを削除
          deleteColEnd1 = colMinus1(deleteColStart2)
          
          deleteArea = sheet1.VPageBreaks(i).Location.Address
          deleColNo = InStr(2, deleteArea, "$")
          deleteCol = Mid(deleteArea, 2, deleColNo - 2)
          deleteColStart2 = deleteCol
          ActiveSheet.Columns(deleteColStart2 & ":IV").Delete
          ActiveSheet.Columns(deleteColStart1 & ":" & deleteColEnd1).Delete
      Next i
      Call fileSave
      Call datacopy
      
      deleteColEnd1 = colMinus1(deleteColStart2)
      ActiveSheet.Columns(deleteColStart1 & ":" & deleteColEnd1).Delete
      Call fileSave
  End Sub
  Sub datacopy()
      Dim copyarea As String
      Dim deleteRow As String
      Dim deleteCol As String
      Dim deleColNo As Integer
      
      sheet1.Activate
      
      copyarea = sheet1.PageSetup.PrintArea
      deleteRow = Right(copyarea, Len(copyarea) - InStrRev(copyarea, "$")) + 1
      deleColNo = InStrRev(copyarea, "$", Len(copyarea) - Len(deleteRow) - 1)
      deleteCol = Mid(copyarea, deleColNo + 1, Len(copyarea) - deleColNo - Len(deleteRow) - 1)
      
      deleteCol = colPlus1(deleteCol)
      
      ' 全てをコピー
      sheet1.Cells.Select
      Selection.Copy
      Workbooks.Add
      ActiveSheet.Paste
      ' 形式を選択してコピーを行う事で、値のみはりつける
      Application.CutCopyMode = False
      Selection.Copy
      Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
          False, Transpose:=False
         
      
      ActiveSheet.Rows(deleteRow & ":65536").Delete
      ActiveSheet.Columns(deleteCol & ":IV").Delete
  End Sub
  Sub fileSave()
  	' 貼り付けたシートの特定のセルの内容をファイル名として出力「Cells(3,5)」を出力したいファイルのあるセルに変更する
      ActiveWorkbook.SaveAs Filename:=ActiveSheet.Cells(3, 5).Value & ".xls", FileFormat:=xlNormal, _
          Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
          CreateBackup:=False
      ActiveWindow.Close
  End Sub
  Function colPlus1(strCell As String) As String
      Dim strCell1 As String
      Dim strCell2 As String
      
      If Len(strCell) = 2 Then
          strCell1 = Left(strCell, 1)
          strCell2 = Right(strCell, 1)
      Else
          strCell1 = "@" ' 文字の大小比較のために適当な文字を設定(1桁繰り上がればAとなる文字)
          strCell2 = strCell
      End If
      
      If strCell2 = "Z" Then
          strCell1 = Chr(Asc(strCell1) + 1)
          strCell2 = "A"
      Else
          strCell2 = Chr(Asc(strCell2) + 1)
      End If
      If strCell1 = "@" Then
          strCell1 = ""
      End If
      
      colPlus1 = strCell1 & strCell2
  End Function
  Function colMinus1(strCell As String) As String
      Dim strCell1 As String
      Dim strCell2 As String
      
      If Len(strCell) = 2 Then
          strCell1 = Left(strCell, 1)
          strCell2 = Right(strCell, 1)
      Else
          strCell2 = strCell
      End If
      
      If strCell2 = "A" Then
          strCell1 = Chr(Asc(strCell1) - 1)
          strCell2 = "Z"
      Else
          strCell2 = Chr(Asc(strCell2) - 1)
      End If
      If strCell1 = "@" Then
          strCell1 = ""
      End If
      
      colMinus1 = strCell1 & strCell2
  End Function
  

posted at 2004/02/23