[[20110209184943]] 『[談]シートレイアウトの投稿どうしてますか?』(momo) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『[談]シートレイアウトの投稿どうしてますか?』(momo)

 皆さんシートレイアウトを投稿するときにどうしてますか?
 コード組まれている方もいらっしゃいますか?

 毎回、意外と面倒なので作ってみました。
 よろしければ使ってください。

  '=====================================================
  ' 投稿用シートレイアウトをクリップボードに取得
  '              作成者(momo)
  '
  ' BrkStr:列間の文字列 初期値は「|」
  ' DataObjectID:DataObjectのLate Binding用(変更不可)
  '=====================================================
  Option Explicit

  Sub SheetlayoutToClipBord()
  Const BrkStr As String = "|"
  Const DataObjectID As String = "1C3B4210-F441-11CE-B9EA-00AA006B1A69"
  Dim myRng As Range, rngFormula As Range, rngBuf As Range
  Dim tbl() As Variant
  Dim AryTxt() As String, StrBuf As String
  Dim i As Long, j As Long, AryWidth() As Long, LenBuf As Long
  Set myRng = Application.InputBox("取得したい範囲を選択してください。", Type:=8)
  If MsgBox("数式として表示したい範囲はありますか?", vbYesNo) = vbYes Then
    Do
      Set rngBuf = Application.InputBox("数式として表示したい範囲を選択してください。", Type:=8)
      If rngFormula Is Nothing Then
        Set rngFormula = rngBuf
      Else
        Set rngFormula = Application.Union(rngFormula, rngBuf)
      End If
      Set rngBuf = Nothing
    Loop While MsgBox("さらに数式として表示したい範囲がありますか?", vbYesNo) = vbYes
  End If
  ReDim tbl(1 To myRng.Rows.Count, 1 To myRng.Columns.Count)
  ReDim AryWidth(1 To UBound(tbl, 2))
  For i = 1 To myRng.Rows.Count
    For j = 1 To myRng.Columns.Count
      tbl(i, j) = myRng.Cells(i, j).Text
      If Not rngFormula Is Nothing Then
        If Not Application.Intersect(myRng.Cells(i, j), rngFormula) Is Nothing Then
          tbl(i, j) = myRng.Cells(i, j).Formula
        End If
      End If
      LenBuf = Application.Evaluate("LENB(""" & Replace(tbl(i, j), """", vbTab) & """)")
      If AryWidth(j) < LenBuf Then
        AryWidth(j) = LenBuf
      End If
    Next j
  Next i
  ReDim AryTxt(UBound(tbl, 1))
  AryTxt(0) = String(Len(myRng.Rows(myRng.Rows.Count).Row) + 3, " ")
  For i = 1 To UBound(tbl, 2)
    StrBuf = "[" & Split(myRng.Columns(i).EntireColumn.Address(False, False), ":")(0) & "]"
    If AryWidth(i) > Len(StrBuf) Then
      AryTxt(0) = AryTxt(0) & BrkStr & StrBuf & String(AryWidth(i) - Len(StrBuf), " ")
    Else
      AryTxt(0) = AryTxt(0) & BrkStr & StrBuf
      AryWidth(i) = Len(StrBuf)
    End If
  Next i
  For i = 1 To UBound(tbl, 1)
    AryTxt(i) = " [" & myRng.Rows(i).Row & "]" & _
                String(Len(myRng.Rows(myRng.Rows.Count).Row) - Len(myRng.Rows(i).Row), " ")
    For j = 1 To UBound(tbl, 2)
      LenBuf = Application.Evaluate("LENB(""" & Replace(tbl(i, j), """", vbTab) & """)")
      If IsNumeric(tbl(i, j)) Then
        AryTxt(i) = AryTxt(i) & BrkStr & String(AryWidth(j) - LenBuf, " ") & tbl(i, j)
      Else
        AryTxt(i) = AryTxt(i) & BrkStr & tbl(i, j) & String(AryWidth(j) - LenBuf, " ")
      End If
    Next j
  Next i
  With GetObject("new:" & DataObjectID)
    .SetText Join(AryTxt, vbCrLf)
    .PutInClipboard
  End With
  MsgBox "クリップボードにコピーしました。"
  End Sub

 (momo)2011/2/10 16:58 修正


    |[B]         |[C]        |[D]        |[E]        |[F]        
 [2]|            |4月        |5月        |6月        |7月        
 [3]|カラーテレビ|       1100|        540|        650|        330
 [4]|掃除機      |        250|        430|        510|        310
 [5]|洗濯機      |        410|        530|        580|        660
 [6]|冷蔵庫      |        120|        100|         80|        130
 [7]|合計        |=SUM(C3:C6)|=SUM(D3:D6)|=SUM(E3:E6)|=SUM(F3:F6)

 簡単なテスト、なるほど便利ですね。(kazu)

 momoさん、気が付いた点があります。
 
 時間や日付等の書式設定が活かせる方法はありますでしょうか?
 
[[20110209180425]] 『特定のチェック付きを抜かしたリストを関数で』(にしき)
 また、こちらでテスト使用させていただいた数式が反映しなかったんですよね〜
 なぜだかは、検証しきれていません。。。
 数式の長さではないと思うのですが・・・
 
 以上が気が付いた点ですb
 (キリキ)(〃⌒o⌒)b

 書式設定、なるほどValueをTextにすればいいので変更します。

 数式が反映されない件も調べてみます〜
 (momo)

 momoさん♪

 凄く便利ですね★改良されるのかな?
 思い切り使用させて頂きます☆彡
 いつも勉強させてもらってます(^^)v

 (MJ12)

 MJ12さんありがとうございます。

 キリキさんのご指摘の件修正しましたので試してみて頂ければと思います。

 書式を加味してValueからText取得にしました。
 数式が反映されない原因は数式内に「"」があったために
 Evaluateで文字列区切りが発生したためでしたのでTabに置換してから処理してます。

 (momo)

 momoさん 

 了解です★ありがとうございます☆彡

 (MJ12)

 完璧ですb
 
 たくさん使わせていただきますね^^

 (キリキ)(〃⌒o⌒)b

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.