[[20120330131914]]　『sheet1からsheet2へ変則コピー』（ＯＬ）　ページの最後に飛ぶ

『sheet1からsheet2へ変則コピー』（ＯＬ）

 （excel2010）
 sheet1からsheet2へ、下記の法則でコピーするマクロを教えて下さい。
 宜しくお願いします。 
・sheet1のB列に、10個のデータがあります。
 ・1(赤)は、値が1でセルが赤で塗ってあるの意味です。
 ・昇順でsheet2へ5行毎コピーする。セルの色もコピーする。
 ・C列はB列と同じ色にする。E列はD列と同じ色にする。
 ・重複した値は1つだけコピーする。

  sheet1
      A     B 
  1     
  2      1(赤)
  3      3(赤)
  4      5(黄)
  5      2(赤)
  6      6(黄)
  7      9(緑)
  8      2(赤)
  9     10(緑)
 10      4(黄)

  sheet2
      A    B      C      D      E
  1     
  2      1(赤)   (赤)   6(黄)  (黄)
  3      2(赤)   (赤)              
  4      3(赤)   (赤)              
  5      4(黄)   (黄)   9(緑)  (緑)
  6      5(黄)   (黄)  10(緑)  (緑)

確認ですけれど、
・同じ数値が違う色で塗ってあったらどうするのでしょうか？
・数値は必ず１～10で、使われていない数値は例示のようにあけるということでしょうか？
(Mook)

 数字が1～10 という前提で。

 Sub Sample()
    Dim c As Range
    Dim sh1 As Worksheet
    Dim i As Long
    Dim j As Long

    Application.ScreenUpdating = False

    Set sh1 = Sheets("Sheet1")

    With Sheets("Sheet2")
        .Cells.Clear
        For Each c In sh1.Range("B1", sh1.Range("B" & sh1.Rows.Count).End(xlUp))
            If Not IsEmpty(c.Value) Then
                i = ((c.Value - 1) Mod 5) + 1
                j = ((((c.Value - 1) \ 5) + 2) - 1) * 2
                With .Cells(i, j)
                    .Value = c.Value
                    .Interior.Color = c.Interior.Color
                    .Offset(, 1).Interior.Color = .Interior.Color
                End With
            End If
        Next
        .Select
    End With

    Set sh1 = Nothing

    Application.ScreenUpdating = True
    MsgBox "組み替え完了"

 End Sub

 同じ数字で違う色があれば後がち

 (ぶらっと)

 (Mook)さん(ぶらっと)さんへ。思い通りに出来ました。
　
　VBAは始めたばかりですので、このコードで勉強させていただきます。
　有難う御座いました。
 （ＯＬ）

 恥ずかしながら質問させて下さい。
 戴いたコードの中で、アクティブセルから右1つのセルを選択と解ったのですが、
  .Offset(, 1).Interior.Color = .Interior.Color
 右3つを範囲選択するにはどの様にすれば良いのでしょうか？
 ↓ではエラーとなりました。 
 .Resize(1, 4).Select.Interior.Color = .Interior.Color
 宜しくお願いします。
 （ＯＬ）

Select は不要です。
Resize を使えば、この2行で出来そうですね。

 .Value = c.Value
 .Resize(1, 4).Interior.Color = c.Interior.Color
(Mook)

 >Resize を使えば、この2行で出来そうですね。

 あっ、そうか。もともとの仕様でも、２行でよかったね。
 もう、年寄りの昼寝の時間帯だったので眠くて眠くて。

 (ぶらっと)

 (Mook)さん (ぶらっと)さん
 有難う御座いました。
 出来ました。

 もう一つ質問お願いします。
  .Resize(1, 4).Interior.Color = c.Interior.Color
 で出来たのですが、現在2列目はD列に書かれます。
 これをG列に書く場合の御指導お願いします。
 （ＯＬ）

 ふっふっふ。今、D列はどうなるのと、レスしようとしていたところ。
ところで、Sheet1のB列のものをSheet2のB列とD列にセットしようとしたとき、それはB列かD列か、そして何行目なのかは
行は　i = ((c.Value - 1) Mod 5) + 1
列は　j = ((((c.Value - 1) \ 5) + 2) - 1) * 2
この計算で出している。
新しい要件でも行はかわらないので、列の計算式を変えるんだけど、これはＶＢＡの課題ではなく「算数」の課題。
自分でがんばってみない？
ちなみに、j を出しているコードを日本語にすると
　
j = (Sheet1のセルの値 -1 ) を 5 で割った、商（あまりは無視）に 2 を足したものから 1 を引いて　その答えに 2 をかけている。
　
あっ、今気がついた。2 を足して 1を引くのなら、最初から 1 を足せばよかったね。まぁ、いぃか。ご愛嬌。
　
追記）　あっ！またまた気がついた。アップした j の計算式は、元シートのB列に10以上のどんな値が入っても
　それにふさわしい列を求める式だったんだけど、１０までに限定するなら　値が 5までなら
　B列、6以上ならD列にしたらよかったんだね！
　
　ということは、新しい要件なら、 5 までなら　ｊ= 2、6以上なら j=7 。これならできるでしょ？
　
　出血大サービスで
　j = ((((c.Value - 1) \ 5) + 2) - 1) * 2
　これにかえて
    If c.Value > 5 Then
        j = 7
    Else
        j = 2
    End If

　
(ぶらっと)

 (ぶらっと) さん　出欠大サービス有難う御座います。
 これで解りました。
 　j = ((((c.Value - 1) \ 5) + 2) - 1) * 2
 では解りませんでした。
 馬鹿な(OL)でご迷惑お掛けしました。
 （ＯＬ）

下記の様にしたいのですが、私の能力では無理でした。
sheet1のC列に文字がある場合、sheet2にもコピーしたい。
宜しくお願いします。

  sheet1
      A     B    C
  1     
  2      1(赤)   d
  3      3(赤)   w
  4      5(黄)   r
  5      2(赤)   y
  6      6(黄)   s
  7      9(緑)   x
  8      2(赤)   y
  9     10(緑)   h
 10      4(黄)   j

  sheet2
      A    B      C      D      E
  1     
  2      1(赤)  d(赤)   6(黄)  s(黄)
  3      2(赤)  y(赤)              
  4      3(赤)  w(赤)              
  5      4(黄)  j(黄)   9(緑)  x(緑)
  6      5(黄)  r(黄)  10(緑)  h(緑)

 (ぶらっと)さんに教えて戴いたマクロです。
 Sub Sample()
    Dim c As Range
    Dim sh1 As Worksheet
    Dim i As Long
    Dim j As Long

    Application.ScreenUpdating = False

    Set sh1 = Sheets("Sheet1")

    With Sheets("Sheet2")
        .Cells.Clear
        For Each c In sh1.Range("B1", sh1.Range("B" & sh1.Rows.Count).End(xlUp))
            If Not IsEmpty(c.Value) Then
                i = ((c.Value - 1) Mod 5) + 1
　　　　　　　  If c.Value > 5 Then
　　　　　　　　   j = 7
　　　　　　　　Else
 　　　　　　      j = 2
 　　　　　　　 End If
                With .Cells(i, j)
                    .Value = c.Value
                    .Interior.Color = c.Interior.Color
                    .Offset(, 1).Interior.Color = .Interior.Color
                End With
            End If
        Next
        .Select
    End With

    Set sh1 = Nothing

    Application.ScreenUpdating = True
    MsgBox "組み替え完了"

 End Sub

 （ＯＬ）

 ↑でアップされたコードはSheet2のB,G列にしているので、そのまま。(質問サンプルは B,D列になってるけど）

 Mookさんのアドバイス、３行で転記せずとも２行でＯＫというところも加味。

 Sub Sample2()
    Dim c As Range
    Dim sh1 As Worksheet
    Dim i As Long
    Dim j As Long

    Application.ScreenUpdating = False

    Set sh1 = Sheets("Sheet1")

    With Sheets("Sheet2")
        .Cells.Clear
        For Each c In sh1.Range("B1", sh1.Range("B" & sh1.Rows.Count).End(xlUp))
            If Not IsEmpty(c.Value) Then
                i = ((c.Value - 1) Mod 5) + 1
                If c.Value > 5 Then
                   j = 7
                Else
                   j = 2
                End If
                With .Cells(i, j)
                    .Resize(, 2).Value = c.Resize(, 2).Value
                    .Resize(, 2).Interior.Color = c.Interior.Color
                End With
            End If
        Next
        .Select
    End With

    Set sh1 = Nothing

    Application.ScreenUpdating = True
    MsgBox "組み替え完了"

 End Sub

 (ぶらっと)

 (ぶらっと)さん　度々の回答に感謝致します。
 有難う御座いました。

 （ＯＬ

コメント返信：

[ 一覧(最新更新順) ]

[[20120330131914]] 『sheet1からsheet2へ変則コピー』（ＯＬ） ページの最後に飛ぶ

[[20120330131914]]　『sheet1からsheet2へ変則コピー』（ＯＬ）　ページの最後に飛ぶ