[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『一つのセルから結合したセルに貼り付ける』（結合）
お世話になります。
単独セルを結合したセルに貼り付ける方法はありますでしょうか。
A B C D E
1 2 3 4 5 6
のデータを
ABの結合 CDの結合 EFの結合 GHの結合 IJの結合
1 2 3 4 5 6
このような感じです。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
Sub test()
Dim wk1 As Worksheet
Dim wk2 As Worksheet
Dim i As Long
Dim j As Long
Set wk1 = Sheets("Sheet1")
Set wk2 = Sheets("Sheet2")
For i = 1 To wk1.Cells(wk1.Rows.Count, "A").End(xlUp).Row
For j = 0 To 4
wk2.Cells(i, j * 2 + 1).Value = wk1.Cells(i, j + 1).Value
Next j
Next i
End Sub
（???） 2016/08/18(木) 16:15
値だけで良いなら数式でも、
Sheet1のA1:E1にデータ、Sheet2が
ABの結合 CDの結合 EFの結合 GHの結合 IJの結合
となっているとして、Sheet2のA1に
=OFFSET(Sheet1!$A$1,0,FLOOR(COLUMN(A1)/2,1))
で右方にフィルコピー
（ウッシ） 2016/08/18(木) 16:20
>マクロを使って、1セルずつ代入するとか？
Sub test()
Dim R As Range
Dim D As Range
Set R = Worksheets("Sheet1").Range("A1")
Set D = Worksheets("Sheet2").Range("A1")
Do Until R.Value = ""
D.Value = R.Value
Set R = R.Offset(, 1)
Set D = D.Offset(, 1)
Loop
End Sub
とか？
（とおりすがり） 2016/08/18(木) 19:11
皆さん本当にありがとうございます。 大変なミスをしてしまいました。 最初の質問は行〜行の結合と例をだしましたが 実際は、Sheet1の列データーをSheet2に Sheet1のデータを行列を入れ替えて貼り付けることは出来るでしょうか。 （とおりすがり）さんのマクロ式での変更をお願いしたいと思います。
Sheet1
A B C D 1 東京 神奈川 千葉 埼玉 2 10 14 18 22 3 11 15 19 23 4 12 16 20 24 5 13 17 21 25
Sheet2
A Ｂ ＣＤ ＥＦ ＧＨ ＩＪ 1 東京 10 11 12 13 2 神奈川 14 15 16 17 3 千葉 18 19 20 21 4 埼玉 22 23 24 25
（結合） 2016/08/18(木) 21:09
おはようございます。 後から思ったのですが （とおりすがり）さんのマクロ式での変更をお願いしたいと思います。 と入れた事は指名をしてしまった事になるのでしょうか それでしたら申し訳ございません。 （とおりすがり）さんの 式を利用して、どなたかのサポートが欲しかったのです。 学校内の事情分からずして大変申し訳ございません。 よろしくお願い致します。 （結合） 2016/08/19(金) 06:53
Sub test2()
Dim RR As Range
Dim R As Range
Dim D As Range
Dim Bc As Long
Set RR = Worksheets("Sheet1").Range("A1").CurrentRegion
Bc = RR.Columns.Count
Set R = RR.Range("A1")
Set D = Worksheets("Sheet2").Range("A1")
Do Until R.Value = ""
Do Until R.Value = ""
D.Value = R.Value
Set R = R.Offset(, 1)
Set D = D.Offset(1)
Loop
Set R = R.Offset(1, -Bc)
Set D = D.Offset(-Bc)
Set D = D.Offset(, 1)
Loop
End Sub
面倒くさいから、以上で打ち止め。ww
（とおりすがり） 2016/08/19(金) 10:06
Sub test1()
Dim wk1 As Worksheet
Dim wk2 As Worksheet
Dim i As Long
Dim j As Long
Set wk1 = Sheets("Sheet1")
Set wk2 = Sheets("Sheet2")
With wk1
i = .Range("A1").End(xlToRight).Column
j = .Range("A" & Rows.Count).End(xlUp).Row
End With
With wk2.Range("A1").Resize(i, j * 2)
.Formula = _
"=OFFSET(Sheet1!$A$1,FLOOR(COLUMN(A1)/2,1),ROW(A1)-1)"
.Value = .Value
End With
End Sub
こんな感じでも。
（ウッシ） 2016/08/19(金) 10:20
Sub test()
Dim wk1 As Worksheet
Dim wk2 As Worksheet
Dim R As Range
Dim D As Range
Dim i As Long
Set wk1 = Sheets("Sheet1")
Set wk2 = Sheets("Sheet2")
For i = 1 To wk1.Cells(1, wk1.Columns.Count).End(xlToLeft).Column
Set R = wk1.Cells(1, i)
Set D = wk2.Cells(i, 1)
Do Until R.Value = ""
D.Value = R.Value
Set R = R.Offset(1)
Set D = D.Offset(, 1)
Loop
Next i
End Sub
こっちは、私自身の変更案。
Sub test2()
Dim wk1 As Worksheet
Dim wk2 As Worksheet
Dim i As Long
Dim j As Long
Dim iMax As Long
Set wk1 = Sheets("Sheet1")
Set wk2 = Sheets("Sheet2")
iMax = wk1.Cells(1, wk1.Columns.Count).End(xlToLeft).Column
For i = 1 To wk1.Cells(wk1.Rows.Count, "A").End(xlUp).Row
For j = 1 To iMax
wk2.Cells(j, i * 2 - 1).Value = wk1.Cells(i, j).Value
Next j
Next i
End Sub
（???） 2016/08/19(金) 10:24
さすがは???さんですね、いやーお見事。 （変な意味ではなく本当に感心しています。ww）
（とおりすがり） 2016/08/19(金) 10:33
（???）さんの 2016/08/19(金) 10:24で解決いたしました。 改めてありがとうございました。 一つ謝らなければならない事があります。 一回ごとの質問でニックネームを入れ替えるのかと思い ニックネームを変更してしまいました。 言い訳がましいですが大変申し訳ございませんでした。 今後ともよろしくお願い致します。
追伸：今後は（日にち）で参加させて下さい。 申し訳ございませんでした。
（日にち） 2016/08/28(日) 10:22
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.