Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


53564 / 76736 ←次へ | 前へ→

【27984】Re:3段組のデータを2段組に仕上げる
回答  kobasan  - 05/8/25(木) 22:03 -

引用なし
パスワード
   ▼YN62 さん 今晩は
これでできると思います

Sheet2 で RRR が重複しているのが気になりますが、
試してみてください。

Sub 異なる表組みへの転記()
Dim k As Integer
Dim r1 As Range, r2 As Range
Dim 範囲11 As Range, 範囲12 As Range, 範囲13 As Range
Dim 範囲21 As Range, 範囲22 As Range
Dim UnionRng1 As Range, UnionRng2 As Range
  '
  With Sheets("Sheet1")
    Set 範囲11 = .Range("A4", .Cells(65536, "A").End(xlUp).Offset(-1))
    Set 範囲12 = .Range("C4", .Cells(65536, "C").End(xlUp).Offset(-1))
    Set 範囲13 = .Range("E4", .Cells(65536, "E").End(xlUp).Offset(-1))
  End With
  With Sheets("Sheet2")
    Set 範囲21 = .Range("A2", .Cells(65536, "A").End(xlUp).Offset(-1))
    Set 範囲22 = .Range("D2", .Cells(65536, "D").End(xlUp).Offset(-1))
  End With
  '
  Set UnionRng1 = Union(範囲11, 範囲12, 範囲13)
  Set UnionRng2 = Union(範囲21, 範囲22)
  '
  For Each r1 In UnionRng1
  For Each r2 In UnionRng2
    If r1.Value = r2.Value Then
      r2.Offset(, 1).Value = r1.Offset(, 1).Value
    End If
  Next
  Next
  '
  Set 範囲11 = Nothing
  Set 範囲12 = Nothing
  Set 範囲13 = Nothing
  Set UnionRng1 = Nothing
  Set UnionRng2 = Nothing
End Sub


>シート1の三段組のデータを
>シート2に二段組のデータに仕上げたく思っています。
>
>シート1の行は30行くらいです。
>
>シート1と2の合計欄にはシート関数(Σ)が入っています。
>
>シート1
>氏名 点数1    氏名 点数1    氏名 点数 1    
>AAA   5    FFF  4      YYY  5    
>CCC   7    GGG  3      OOO  6    
>BBB   8    KKK  7      PPP  10    
>DDD   8    SSS  6      RRR  4    
>合計  29    合計  20     合計  25    
>
>シート2
>    A    B    C    D    E    F
>1    氏名  点数1 点数2  氏名  点数1  点数 2
>2    AAA    5       KKK    7    
>3    CCC    7       RRR    4    
>4    DDD    8       OOO    6    
>5    BBB    10        RRR    4    
>6    GGG    3       SSS    6    
>7    FFF    4                
>8    合計   37    0   合計   27    0
>
>※氏名の順番は、シート1とシート2は異なります。
>※シート2には氏名PPPはこの集計にはたまたま有りませんでした    
>※点数2はシート1と同じような別のデータがあり、同じようにこのシートの氏名を基準に順次貼り付けてシート2の完成です。
>
>
>自分なりにマクロのコードを書きましたが、列がまたがってくるとどのように書けばよいのか分かりません。ご指導の程お願いいたします。
>
>
>Sub 異なる表組みへの転記()
>
>Dim k As Integer
>Dim R As Range
>Dim MyR As Range
>
>For k = 2 To 31
>
>Set MyR = Range(("A4"), Cells(65536, 1).End(xlUp))
>For Each R In MyR
>If R.Value = Sheets(2).Cells(k, 1).Value Then
>Sheets(2).Cells(k, 1).Offset(, 1).Value = R.Offset(, 1).Value
>
>End If
>
>Next
>Next
>
>End Sub

0 hits

【27980】3段組のデータを2段組に仕上げる YN62 05/8/25(木) 21:13 質問
【27984】Re:3段組のデータを2段組に仕上げる kobasan 05/8/25(木) 22:03 回答
【27990】Re:3段組のデータを2段組に仕上げる YN62 05/8/25(木) 23:37 お礼
【28034】Re:3段組のデータを2段組に仕上げる YN62 05/8/26(金) 22:02 質問
【28035】Re:3段組のデータを2段組に仕上げる kobasan 05/8/26(金) 22:38 回答
【28037】Re:3段組のデータを2段組に仕上げる kobasan 05/8/26(金) 23:06 発言
【28042】Re:3段組のデータを2段組に仕上げる YN62 05/8/27(土) 8:09 質問
【28045】Re:3段組のデータを2段組に仕上げる kobasan 05/8/27(土) 10:21 回答
【28091】Re:3段組のデータを2段組に仕上げる YN62 05/8/28(日) 15:25 お礼
【28105】Re:3段組のデータを2段組に仕上げる kobasan 05/8/28(日) 22:11 発言
【28141】Re:3段組のデータを2段組に仕上げる YN62 05/8/29(月) 20:16 質問
【28143】Re:3段組のデータを2段組に仕上げる kobasan 05/8/29(月) 21:08 回答
【28232】Re:3段組のデータを2段組に仕上げる YN62 05/8/31(水) 21:04 お礼

53564 / 76736 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free