• ベストアンサー

一定の規則でエクセルに並んでいる表を、別シートに元のSheetに設定されているNO順で貼り付ける

少しややこしいマクロなのですが、 Sheet1に表が左から順に飛び飛びで並んでいます。 1番目の表の1行目の項目値がNO.1で、2番目の表の1番目がNO.2、3番目の表の1番目がNO.3で。。。。と続いていき、最後の表の1行目までいくと、一番始めの表の2行目に続きます。 それを別シートにNO順に1つの表として完成させるマクロをVBAで作りたいと思っています。 調べ回って途中まではやってみたのですが、一向に進まないので教えて下さい(*_ _) 以下はエラーになったマクロです。 Sub CopyCell() Dim CopySource, PasteDist As Range Dim i As Integer Dim j As Integer Dim k As Integer For i = 1 To 7 For j = 1 To 7 For k = 2 To 33 Step 8 Set CopySource = Sheets(1).Range(Cells(i, k), Cells(i, k + 6)) Set PasteDist = Sheets(2).Range(Cells(j, 1), Cells(j, 7)) PasteDist = CopySource Next k Next j Next i End Sub

この投稿のマルチメディアは削除されているためご覧いただけません。
noname#86919
noname#86919

質問者が選んだベストアンサー

  • ベストアンサー
  • Yosha
  • ベストアンサー率59% (172/287)
回答No.2

もう少し、簡単な方法です。 なるべく、あなたの方法に近づけてやってみます。 Sub CopyCell()  Dim i As Integer  Dim j As Integer  Dim k As Integer    For i = 1 To 7      For j = 2 To 33 Step 8        k = k + 1        Sheets(1).Range(Cells(i, j), Cells(i, j + 6)).Copy Destination:=Sheets(2).Cells(k, 1)      Next j    Next i End Sub でいけます。

noname#86919
質問者

お礼

なるほど! 2重ループでできるんですね。 勉強になりました。ありがとうございました <(_ _)>

その他の回答 (1)

  • soixante
  • ベストアンサー率32% (401/1246)
回答No.1

投稿するカテを間違えてしまいましたか(笑) ソフトウエア→Office系ソフト のところに行くと詳しい方がたくさんいます。 それはさておき。 表の形式がどうなってるか質問文だけでは分からないので、コードから推測してみました。 ・B1セルを起点にして、7行×7列の表がある ・2番目の表は、J1セル起点。(1番目の表との間には1列空白がある?) ・3番目以降も同様に、1列ずつ空白列を入れて、表が5つある でしょうか?このあたりはっきりしたほうが回答は付きやすいです。 また、それを1行づつ別のシートにまとめたいということでいいですか。 新しいシートには、 1番目の表の1行目 2番目の表の1行目 3番目の表の1行目 4番目の表の1行目 5番目の表の1行目 1番目の表の2行目 以下続き、 5番目の表の7行目 でしょうか。であれば、 Sub aaa() Dim k As Integer Dim i As Integer Dim CopySource As Range For i = 1 To 7     For k = 2 To 34 Step 8      Set CopySource = Range(Worksheets(1).Cells(i, k), Worksheets(1).Cells(i, k + 6))     CopySource.Copy Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)    Next k Next i Set CopySource = Nothing Rows(1).Delete End Sub こんなんでどうでしょう。 ※上述どおり、推測で書いてますので、あなたの意図通りになってないかもしれません。ついては試す際には、元データはコピー、保存のうえ、トライしてください。

noname#86919
質問者

お礼

カテ間違ってました(^^;) すみません、説明不足でした。 質問はご指摘のとおりです。 私のわかりにくい説明でそこまで理解して頂き、有難いです。 教えて頂いたコードで実行してみたら、できました! どうもありがとうございました <(_ _)>

関連するQ&A

  • VBAでの質問

    お世話になります。 下記の記述で、「←」の矢印の記述で、 Cells.(5,2)がブランクでなければ、 「→」から進めたいのですが、 どの様に記述すれば宜しいでしょうか ご教示お願いします。 Sub 表記入() Dim Data As Range Dim i As Integer Dim j As Integer Dim k As Integer Set Data = Sheets("集計").Range("A2").CurrentRegion j = 16 k = 0 With Sheets("表") For i = 3 To Data.Rows.Count If Data.Cells(i, 51) <> "" Then .Cells(5, 2) = Data.Cells(i, 3)  ← .Cells(5, 7) = Data.Cells(i, 4) → .Cells(j, 2) = Data.Cells(i, 10) .Cells(j, 6) = Data.Cells(i, 11) & Data.Cells(i, 12) .Cells(j, 14) = Data.Cells(i, 51) Else End If k = k + 1 If k = 10 Then j = j + 18 k = 0 Else j = j + 1 End If End If Next i End With End Sub

  • データ検索ネスト Excel VBA

    excel2003でデータ検索の処理をするというマクロをVBAで作成したいのですが、うまく動作しません。自作のVBAを記載してみましたので何が原因なのか教えてください。初心者です、よろしくお願いします。 Sub データ検索() Dim i As Integer, j As Integer, k As Integer, l As Integer Dim myRange As Range Dim IngLastrow As Long IngLastrow = Range("A65536").End(xlUp).Row For i = 3 To IngLastrow For j = 3 To 25 For k = 8 To 53 For l = 3 To 9 Set myRange = Worksheets("データベース").Cells(i, "o").Find(what:=Worksheets("コード").Cells(j, "o").Value, _ LookIn:=xlValues) If Not myRange Is Nothing Then Worksheets("予定").Cells(k, l).Value = myRange.Offset(, -12).Value End If Next l Next k Next j Next i End Sub

  • マクロが実行しない

     二行三列を一枡として月の勤務割表を作成しています。マクロで同じ事を しているのにMacro1の方が実行しません。お教え願えませんでしょうか。 (尚、図形を枠線上にコピペしています。) Sub Macro1()実行しません。 Dim i As Integer Dim j As Integer For i = 10 To 43 Step 2 For j = 10 To 103 Step 3 Select Case Cells(i, j).Value Case 1: ActiveSheet.Shapes("四角形1").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste End Select Next Next End Sub Sub Macro2()実行します。 ActiveSheet.Shapes.Range(Array("四角形1")).Select Selection.Copy Range("J11:K11").Select ActiveSheet.Paste End Sub

  • チェックボタンでチェックした値をセルに連続入力

    チェックボタンでチェックした行(表-1)を下記のコードでExcelセル(表-2)に入力できたのですが既にに"B2:E3","B10:E10",に値が入力されている場合、B4から続けて入力したいのですがどのように コードを追記すれば良いのかどなたかわかる方よろしくお願いします。 Sub 入力() Dim i As Integer Dim j As Integer Dim k As Integer k = 3 i = Range("Z65536").End(xlUp).Row For j = 3 To i If Range("Z" & j).Value = True Then k = k + 1 Range("B" & k).Value = k - 1 Range("H" & j, "K" & j).Copy Range("B" & k) End If Next j End Sub

  • 行ごとに判定するマクロについて教えて下さい

    行ごとに判定するマクロについて教えて下さい。 下記のようなマクロで、添付ファイルのように、行ごとで E列からN列で違った数値がないか、入力されていないセルがないかを調べ 4つすべてのセルが同じ数値でない場合は塗りつぶしはされず O列にOKを表示しないようなマクロを組みたいのですが 現在のマクロだと、行ごとではなく、E3~N102セルまでの中で 同じ数値がないかを判断してしまっているため K11セルやK15セルのように数値が入力されていないにも関わらずO列の部分にOKが出てしまいます。 他の行に同じ数値が入っているのは関係なしにして 11行目なら11行目だけで 15行目なら15行目だけで、というように行ごに判定していくには どのようにすればいいでしょうか? Sub 判定マクロ回転() Dim i As Integer, j As Integer Range(Cells(3, 15), Cells(102, 15)).ClearContents For i = 3 To 102 For j = 5 To 14 Cells(i, j).Interior.ColorIndex = 0 If WorksheetFunction.CountIf(Range("E3:N102"), Cells(i, j)) > 3 Then If Cells(i, j).Row Mod 2 = 1 Then Cells(i, j).Interior.ColorIndex = 6 Cells(i, 15) = "OK" Else If Cells(i, j).Row Mod 2 = 0 Then Cells(i, j).Interior.ColorIndex = 40 Cells(i, 15) = "OK" End If End If End If Next j Next i If WorksheetFunction.CountIf(Range("O3:O102"), "OK") > 99 Then MsgBox "データチェックOK(^O^)b" End If End Sub

  • 判定してセルを塗りつぶすマクロについて

    判定してセルを塗りつぶすマクロについて教えて下さい。 現在下記のようなマクロがあります。 Sub オニオン判定() Dim i As Integer, j As Integer, r As Integer Dim k As Double Range(Cells(17, 9), Cells(26, 14)).Interior.ColorIndex = 0 Range(Cells(30, 9), Cells(39, 14)).Interior.ColorIndex = 0 k = Cells(5, 2) 'B5セルの値 For j = 9 To 14 For i = 17 To 26 For r = 30 To 39 If Abs(Cells(i, j).Value - Cells(r, j).Value) <= 0.05 Then Cells(r, j).Interior.Color = vbYellow Cells(i, j).Interior.Color = vbYellow End If Next  Next   Next End Sub 対象のIf Abs(Cells(i, j).Value - Cells(r, j).Value) <= 0.05 Then で、それぞれ見比べて、0.05以上のずれがあるとセルが塗りつぶされないというマクロなのですが これを、If Abs(Cells(i, j).Value - Cells(r, j).Value) = 0 Thenという条件も追加して その時はセルを青に塗りつぶし、逆に0.05以上のずれがあるセルは赤に塗りつぶす。 みたいなマクロを書きたいです。 If Abs(Cells(i, j).Value - Cells(r, j).Value) = 0 Thenは一度追加してみましたが 上手く機能しませんでした。 やりたい事 ・数値が動いているけど、0.05以内の時は黄色 ・数値変動が0の場合は青 ・数値変動が0.05以上の場合は赤 です。 宜しくお願いします。

  • Excel マクロ:変数を複数使う場合

    マクロ初心者です。 For文で、変数を2つ定義し、それぞれが1つずつ増えてくれるような マクロを組みたいのですが、うまくいきません。 例えばA列の並んだ数字を、B列に一個とばしで入力するとして・・・ 例) Dim i As Integer Dim j As Integer For j = 2 To 10 Step 2 For i = 1 To 9 Cells(j, 2).Value = Cells(i, 1).Value Next i, j ではだめですよね。iが1つ増える時に、jも1つ増える、 というようにVBAを組むことが可能なのでしょうか? ど素人な質問ですみませんが、教えてください。

  • VBA セルの値を取得する

    下記のはランダムにチーム分けするものです。 TmCnt = 5がチーム数です。 Sub Sample() Dim Total As Integer Dim TmCnt As Integer Dim Data1 As Variant Dim Data2() As String Dim i As Integer, j As Integer, k As Integer Total = Cells(Rows.Count, 1).End(xlUp).Row TmCnt = 5 Data1 = Range("A1:A" & Total).Value ReDim Data2(1 To Total) Randomize For i = TmCnt To 1 Step -1 j = Int(Rnd * i) + 1 Data2(i) = Data1(j, 1) Data1(j, 1) = Data1(i, 1) Next i For i = Total To TmCnt + 1 Step -1 j = Int((i - (TmCnt + 1) + 1) * Rnd + TmCnt + 1) Data2(i) = Data1(j, 1) Data1(j, 1) = Data1(i, 1) Next i i = 1 Do For j = 1 To TmCnt k = k + 1 Cells(i, j + 2).Value = Data2(k) If k = Total Then Exit Sub Next j i = i + 1 Loop End Sub TmCnt = 5をセル「B1」にチーム数を入力し、(例「6」「4」など)マクロを実行したいのです。 検索しましたところ、 セルの値を取得するにはRange("A1").Valueを入力だそうです。 TmCnt = 5を下記に書き換えるにはどのようにしたら良いでしょうか? Dim s As String s = Range(“B1”).Value Debug.Print(s) 宜しくお願いします。

  • マクロのプロシージャーの修正

    シートの加工場設定マスタの列が最初は、B列の4行目からD列の30行まで あったのですが、B列が不要になったのでB列を削除しました。 下記のようなマクロを記述していますが何処を修正すればよいか 教えてください。 Private bmas(20,3) Sub Kmas_call() Dim i As Integer, j As Integer, k As Integer Windows("加工品.xls").Activate Sheets("加工場設定マスタ").Select For i = 1 To 20 For j = 1 To 3 Bmas(i, j) = Cells(i + 4, j + 1) Next j Next i End Sub

  • VBA リーダーを選出したチーム分け

    名簿を作り、その名前をランダムでチームに分けるようにしたいです。 検索して以下のようなVBAを作成しました。 ※ チーム数は「TmCnt = 5」 Sub Sample() Dim Total As Integer Dim TmCnt As Integer Dim Data1 As Variant Dim Data2() As String Dim i As Integer, j As Integer, k As Integer Total = Cells(Rows.Count, 1).End(xlUp).Row TmCnt = 5 Data1 = Range("A1:A" & Total).Value ReDim Data2(1 To Total) Randomize For i = Total To 1 Step -1 j = Int(Rnd * i) + 1 Data2(i) = Data1(j, 1) Data1(j, 1) = Data1(i, 1) Next i i = 1 Do For j = 1 To TmCnt k = k + 1 Cells(i, j + 2).Value = Data2(k) If k = Total Then Exit Sub Next j i = i + 1 Loop End Sub 問題はA1~A5までの名前をランダムにリーダーとして各チームの1番目に配置する方法はどうしたら良いでしょうか? 宜しくお願いします。