| |
こんにちは。12802でお世話になったimaです。ichinoseさんに教えていだたいたコードをベースに、実際に使う体裁に整えていました。そこである大事なことを忘れていたことに気がつきました。
マクロの実行によりできた集計ブックは
A列 B列 C列
1 シート番号 回答 文字数
2 １ ◎◎ 2
・ ２ ●●●● 4
・ ・ ・ ・
・ ・ ・ ・
・ X \\\ 3
のようになります。
最終目的のひとつは、B２以下の文字列をまとめて別のエクセルファイルのある一つのセル（結合セルで解除できない）に貼り付けること（これは手作業でします）なのですが、複数のセルを別の一つのセルにコピーできないですよね。そこで、
A列 B列 C列
1 シート番号 回答 文字数
2 １ ◎◎ 2
・ ２ ●●●● 4
・ ・ ・ ・
・ ・ ・ ・
・ X \\\ 3
X+2
B（X+2）のセルにB2からBXまでの文字列をコピーしようと考えました。
イメージとしては、下記のように、セル内に上記B列各セルの内容が改行され、頭に「・」がついた形です。
セル B（X+2）
・◎◎
・●●●●
・
・
・\\\
私の力量では、単一（例えばB2）のセル内容をコピーすることしかできませんでした。
過去ログで、別途テキストファイルに書き出すというのを見たのですが、同じシート内ではどう応用していいのかわかりません。
今回の質問に関係ない箇所もありますが、下記にコード全体を載せます。
なお、会社のパソコンなので、連休中返事が遅れるかもしれませんが、よろしくお願いします。
'====================================================================
Option Explicit
'====================================================================
Sub データ処理2()
Dim newshtnm() '集計用シート
Dim oldshtnm() '翻訳入力シート
Dim idx As Long '変数を数値とする
Dim 元ブック As Workbook '翻訳フォーム
Dim 集計ブック As Workbook 'データ処理によりできたファイル（作業ファイル）
Dim total_sht As Worksheet 'トータルシート
idx = 0 '最初の値
Set 元ブック = ActiveWorkbook '翻訳フォームを開く
With 元ブック
ReDim oldshtnm(1 To .Worksheets.Count, 1 To 1) 'シート数を数える
For idx = 1 To Worksheets.Count
oldshtnm(idx, 1) = .Worksheets(idx).Name '質問番号をシート名にする
Next
End With
newshtnm() = Range("a1", Cells(Rows.Count, 1).End(xlUp).Offset(-1, 0)).Value '最後のシートを削除する
Set 集計ブック = mk_book(newshtnm()) '作業ファイルの作成
With 集計ブック
For idx = 1 To .Worksheets.Count
With .Worksheets(idx)
.Range("a1:c1").Value = Array("研修生通し番号", "回答", "文字数") '1行目作成
.Range("d2:d" & UBound(oldshtnm(), 1) + 1).Value = oldshtnm()
.Range("a2:a" & UBound(oldshtnm(), 1) + 1).Formula = "=row()-1" 'A2から研修生通し番号を入れる
.Range("b2:b" & UBound(oldshtnm(), 1) + 1).Formula = _
"=if(indirect(ADDRESS(" & idx & ",2,,,""[" & 元ブック.Name & "]""&d2))="""",""""," & _
"indirect(ADDRESS(" & idx & ",2,,,""[" & 元ブック.Name & "]""&d2)))" 'B列に回答を入れる
.Range("c2:c" & UBound(oldshtnm(), 1) + 1).Formula = "=len(b2)" 'C列にカウントした文字数を入れる
.Cells(UBound(oldshtnm(), 1) + 2, 3).Formula = _
"=sum(c2:c" & UBound(oldshtnm(), 1) + 1 & ")" 'C列の最終行に各シートの文字数小計を入れる
.Columns("b:b").ColumnWidth = 95 '列幅設定
.Columns("a:a").ColumnWidth = 7.25
.Rows("1").RowHeight = 27 '行幅設定
.Range("A1").WrapText = True 'セル折り返し設定
With .Range("a2:b" & UBound(oldshtnm(), 1) + 1)
.Value = .Value
End With
.Range("d2:d" & UBound(oldshtnm(), 1) + 1).Value = ""
End With
If Worksheets(idx).Name = "翻訳者注記（あれば）" Then Columns("c").EntireColumn.Hidden = True 'C列の非表示
Next
Set total_sht = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count)) 'トータルシートの作成
With total_sht
.Name = "トータルシート"
.Range("a1:b1").Value = Array("シート名", "文字数小計")
.Range("a2:a" & UBound(newshtnm(), 1)).Value = newshtnm()
End With
With Range("b2:b" & UBound(newshtnm(), 1) + 1) '小計の設定
.Value = "=indirect(address(" & UBound(oldshtnm(), 1) + 2 & ",3,,,a2))"
.NumberFormat = "###,##0" 'B列桁数区切り
End With
With Cells(UBound(newshtnm(), 1) + 1, 2) '合計値の設定
.Formula = "=sum(b2:b" & UBound(newshtnm(), 1) & ")"
.Font.Bold = True
.Font.ColorIndex = 5
End With
With Cells(UBound(newshtnm(), 1) + 1, 3) '枚数換算設定
.Formula = "(" & (Cells(UBound(newshtnm(), 1) + 1, 2)) / 400 & "枚相当）"
Range(Cells(UBound(newshtnm(), 1) + 1, 1), Cells(UBound(newshtnm(), 1) + 1, 4)).Borders(xlTop).LineStyle = xlContinuous '罫線
End With
End With
End Sub
'====================================================================
Function mk_book(shtnm()) As Workbook
Dim idx As Long
Set mk_book = Workbooks.Add
With mk_book
For idx = LBound(shtnm()) To UBound(shtnm())
If idx > .Worksheets.Count Then
.Worksheets.Add after:=.Worksheets(.Worksheets.Count)
End If
.Worksheets(idx).Name = shtnm(idx, 1)
Next idx
End With
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
