[[20160818160006]] 『一つのセルから結合したセルに貼り付ける』(結合) ページの最後に飛ぶ

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

 

『一つのセルから結合したセルに貼り付ける』(結合)

お世話になります。
単独セルを結合したセルに貼り付ける方法はありますでしょうか。

        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 >


マクロを使って、1セルずつ代入するとか?

 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 B	CD	EF	GH	IJ
 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

地名を抜かせば、"A1"という部分を、実際のデータのあるセルに変えるだけでは? まず、それくらいはご自分でやっていただかないと…。
(???) 2016/08/19(金) 09:26

コード書いたのですが、勘違いしていたので、一旦消します。
(???) 2016/08/19(金) 10:03

 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


元が1行分だったので、複数行対応にするのが面倒ですよね。
とおりすがりさんの案を元にした、私の変更案。
 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.