Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
7489 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【38626】セルの下にまとまって入れ込む ごまみそ 06/6/7(水) 16:12 質問[未読]
【38628】Re:セルの下にまとまって入れ込む Statis 06/6/7(水) 16:24 発言[未読]
【38630】Re:セルの下にまとまって入れ込む ごまみそ 06/6/7(水) 16:34 発言[未読]
【38632】Re:セルの下にまとまって入れ込む Kein 06/6/7(水) 16:38 回答[未読]
【38633】Re:セルの下にまとまって入れ込む Kein 06/6/7(水) 16:41 発言[未読]
【38658】Re:セルの下にまとまって入れ込む ごまみそ 06/6/8(木) 8:19 質問[未読]
【38648】Re:セルの下にまとまって入れ込む ごまみそ 06/6/7(水) 18:44 質問[未読]
【38657】Re:セルの下にまとまって入れ込む ごまみそ 06/6/8(木) 8:13 質問[未読]
【38661】Re:セルの下にまとまって入れ込む Statis 06/6/8(木) 9:27 回答[未読]
【38688】Re:セルの下にまとまって入れ込む Kein 06/6/8(木) 15:30 回答[未読]
【38757】Re:セルの下にまとまって入れ込む ごまみそ 06/6/9(金) 15:42 質問[未読]
【38778】Re:セルの下にまとまって入れ込む Kein 06/6/9(金) 21:48 回答[未読]
【38842】Re:セルの下にまとまって入れ込む ごまみそ 06/6/12(月) 9:34 質問[未読]
【38844】Re:セルの下にまとまって入れ込む ごまみそ 06/6/12(月) 11:16 発言[未読]
【38847】Re:セルの下にまとまって入れ込む Kein 06/6/12(月) 14:20 回答[未読]
【38876】Re:セルの下にまとまって入れ込む ごまみそ 06/6/13(火) 12:42 お礼[未読]
【38626】セルの下にまとまって入れ込む
質問  ごまみそ  - 06/6/7(水) 16:12 -
引用なし
パスワード
   いつもお世話になっています。

シートA
A　　B　　　　
a　山田商店
a　　みかん
a　　りんご
a　　バナナ
･　　　･
･　　　･
･　　　･
･　　　･
･　　　･　
b　　田中商店
b　　　メロン
b　　　イチゴ
b　　　 柿
b　　ノート
b　　　牛乳

上記のようなシートがあります。
このシートの中に商店と名前が付くセルがあり、それぞれで
購入した物のまとまりをAセルの記号で分けています。
今回このまとまり全部を下記のようなシートに入れ込みたい
のです。

＜総合シート＞
A　　　　 B　　　　 C
･　　　　・　　　　中村文具店
･　　　　・　　　　　コピー機
･　　　　・　　　　　コンパス
･　　　　・　　　　山田商店
　　　　　　　　　　（この下は空セルになっている）

・　　　 ・　　　　鈴木花や
・　　　 ・　　　　ひまわり
・　　　 ・　　　　パンジー
・　　　 ・　　　　バラ
　　　　　　　　　 田中商店
　　　　　　　　　(この下は空セル)


・　　　 ・　　　　加藤機器


上記のシートにシートAの〜商店の
かたまりのデータを入れ込みたいのですが
良い方法はないでしょうか？
【38628】Re:セルの下にまとまって入れ込む
発言  Statis  - 06/6/7(水) 16:24 -
引用なし
パスワード
   こんにちは

>今回このまとまり全部を下記のようなシートに入れ込みたいのです。

総合シートの空白はまとまり分の空白があるのでしょうか？
【38630】Re:セルの下にまとまって入れ込む
発言  ごまみそ  - 06/6/7(水) 16:34 -
引用なし
パスワード
   ▼Statis さん：
>こんにちは
>
>>今回このまとまり全部を下記のようなシートに入れ込みたいのです。
>
>総合シートの空白はまとまり分の空白があるのでしょうか？


はい、まとまり以上は空いております。
違うマクロで、空白をつくりました。
【38632】Re:セルの下にまとまって入れ込む
回答  Kein  - 06/6/7(水) 16:38 -
引用なし
パスワード
   ベタ書きですが

Sub MyData_Copy()
　 Dim MyR As Range, C As Range
　 Dim Ck As Variant

　 With Application
　　　.ScreenUpdating = False
　　　.DisplayAlerts = False
　 End With
　 With Worksheets("A")
　　　.Range("A1").Subtotal 1, xlCount, Array(2)
　　　.Range("B:B").SpeclalCells(3).EntireRow.ClearContents
　　　Set MyR = .Range("B:B").SpecialCells(2, 2)
　 End With
　 With Worksheets("総合")
　　　For Each C In MyR.Areas
　　　　 Ck = Application _
　　　　 .Match(C.Range("A1").Value, .Range("C:C"), 0)
　　　　 If IsError(Ck) Then
　　　　　　MsgBox C.Range("A1").Value & _
　　　　　　" の項目が見つかりません", 48
　　　　 Else
　　　　　　C.Range("A1", C.Range("A1").End(xlDown)) _
　　　　　　.Copy .Cells(Ck + 1, 3)
　　　　 End If
　　　Next
　 End With
　 With Worksheets("A")
　　　.Cells.RemoveSubtotal
　　　.Range("A1", .Range("A65536").End(xlUp)) _
　　　.SpecialCells(4).EntireRow.Delete xlShiftUp
　 End With
　 With Application
　　　.ScreenUpdating = True
　　　.DisplayAlerts = True
　 End With　
End Sub

で、どうかな ?
【38633】Re:セルの下にまとまって入れ込む
発言  Kein  - 06/6/7(水) 16:41 -
引用なし
パスワード
   ちょっと訂正。
>C.Range("A1", C.Range("A1").End(xlDown)) _
>.Copy .Cells(Ck + 1, 3)
↓

C.Range("A1", C.Range("A1").End(xlDown)) _
.Copy .Cells(Ck, 3)
【38648】Re:セルの下にまとまって入れ込む
質問  ごまみそ  - 06/6/7(水) 18:44 -
引用なし
パスワード
   ▼Kein さん：
ありがとうございます！

AセルとBセルでやった時にはうまくいったのですが、

色々他のセルにデータがはいっており
先ほどAシートの、AセルのデータがCセルに
BセルのデータがGセルにあります。

総合シートのCセルに入っているデータも
Hセルにあります。

入れ替えてやってみたのですが、エラーがでて動きません。

色々試してみたのですが、何が原因か分かりません。
申し訳ございませんが、教えていただけますか？
【38657】Re:セルの下にまとまって入れ込む
質問  ごまみそ  - 06/6/8(木) 8:13 -
引用なし
パスワード
   皆様方

上記の件、お手数ですが
お願いしますm(__)m
【38658】Re:セルの下にまとまって入れ込む
質問  ごまみそ  - 06/6/8(木) 8:19 -
引用なし
パスワード
   ▼Kein さん：
追加で質問ですが、
セルの行が、5000位あるのですが、
200くらいまでしか、subtotalで分けられないのは
なぜですか？
【38661】Re:セルの下にまとまって入れ込む
回答  Statis  - 06/6/8(木) 9:27 -
引用なし
パスワード
   こんにちは

お試しを。
尚、１行目は項目行であること。

Sub Test_1()
Dim Ws As Worksheet, Da As Variant, R As Range, C As Range
Dim Myma As Variant, Myma1 As Variant, Co As Long, i As Long


Set Ws = Worksheets("総合")
With Worksheets("A")
　　 With .Range("A1", .Range("A65536").End(xlUp))
　　　　　Da = .Value
　　　　　.AdvancedFilter xlFilterCopy, , Worksheets("A").Range("IV1"), True
　　 End With
　　 Set R = .Range("IV2", .Range("IV65536").End(xlUp))
　　 For Each C In R
　　　　 Myma = Application.Match(C.Value, .Columns(1), 0)
　　　　 If Not IsError(Myma) Then
　　　　　　Myma1 = Application.Match(.Cells(Myma, 2).Value, Ws.Columns(3), 0)
　　　　　　If Not IsError(Myma1) Then
　　　　　　　 Co = 0
　　　　　　　 For i = Myma To UBound(Da)
　　　　　　　　　 If Da(i, 1) <> C.Value Then
　　　　　　　　　　　Exit For
　　　　　　　　　 End If
　　　　　　　　　 Co = Co + 1
　　　　　　　 Next i
　　　　　　　 .Cells(Myma + 1, 2).Resize(Co-1).Copy Ws.Cells(Myma1 + 1, 3)
　　　　　　End If
　　　　 End If
　　 Next C
　　 .Columns(256).Clear
End With
Set R = Nothing: Set Ws = Nothing

End Sub
【38688】Re:セルの下にまとまって入れ込む
回答  Kein  - 06/6/8(木) 15:30 -
引用なし
パスワード
   すいません遅くなりましたが、集計機能による分割を止めて数式でやってみます。

Sub MyData_Copy2()
　 Dim MyR As Range, C As Range
　 Dim GetR As Variant

　 Application.ScreenUpdating = False
　 With Worksheets("A")
　　　With .Range("C2", .Range("C65536").End(xlUp)).Offset(, 26)
　　　　 .Formula = "=IF($C1<>$C2,1,"""")"
　　　　 .SpecialCells(3, 1).EntireRow.Insert xlShiftDown
　　　　 .ClearContents
　　　End With
　　　Set MyR = .Range("C1", .Range("C65536").End(xlUp)) _
　　　.Offset(, 4).SpecialCells(2)
　 End With
　 With Worksheets("総合")
　　　For Each C In MyR.Areas　　
　　　　 GetR = Application _
　　　　 .Match(C.Range("A1").Value, .Range("H:H"), 0)
　　　　 If Not IsError(GetR) Then
　　　　　　C.Copy .Cells(GetR, 8)
　　　　 End If
　　　Next
　 End With
　 With Worksheets("A")
　　　.Range("C1", .Range("C65536").End(xlUp)).SpecialCells(4) _
　　　.EntireRow.Delete xlShiftUp
　 End With
　 Application.ScreenUpdating = True: Set MyR = Nothing
End Sub
【38757】Re:セルの下にまとまって入れ込む
質問  ごまみそ  - 06/6/9(金) 15:42 -
引用なし
パスワード
   ▼Kein さん：
昨日はありがとうございます。

コードは大体理解できたのですが、どうしても
読み込んではいけないものを読み込みます。

ちなみにシートAにはもともと
空の行とかA,B,C列には背景色など
ついています。

それらの仕業かも知れません・
すみませんが教えていただきけませんか？
【38778】Re:セルの下にまとまって入れ込む
回答  Kein  - 06/6/9(金) 21:48 -
引用なし
パスワード
   >空の行
は、C列にあるということでしょーか ? それならそこを埋めてしまわないと
うまくいきません。以下のように変更して下さい。

Sub MyData_Copy2()
　 Dim MyR As Range, C As Range
　 Dim GetR As Variant

　 Application.ScreenUpdating = False
　 On Error Resume Next
　 With Worksheets("A")
　　　With .Range("C2", .Range("C65536").End(xlUp))
　　　　 With .SpecialCells(4)
　　　　　　.FormulaR1C1 = "=R[-1]C"
　　　　　　.Value = .Value
　　　　 End With
　　　　 On Error GoTo 0: If Err.Number <> 0 Then Err.Clear
　　　　 With .Offset(, 26)
　　　　　　.Formula = "=IF($C1<>$C2,1,"""")"
　　　　　　.SpecialCells(3, 1).EntireRow.Insert xlShiftDown
　　　　　　.ClearContents
　　　　 End With
　　 End With
　　　Set MyR = .Range("C1", .Range("C65536").End(xlUp)) _
　　　.Offset(, 4).SpecialCells(2)
　 End With
　 With Worksheets("総合")
　　　For Each C In MyR.Areas　　
　　　　 GetR = Application _
　　　　 .Match(C.Range("A1").Value, .Range("H:H"), 0)
　　　　 If Not IsError(GetR) Then
　　　　　　C.Copy .Cells(GetR, 8)
　　　　 End If
　　　Next
　 End With
　 With Worksheets("A")
　　　.Range("C1", .Range("C65536").End(xlUp)).SpecialCells(4) _
　　　.EntireRow.Delete xlShiftUp
　 End With
　 Application.ScreenUpdating = True: Set MyR = Nothing
End Sub
【38842】Re:セルの下にまとまって入れ込む
質問  ごまみそ  - 06/6/12(月) 9:34 -
引用なし
パスワード
   ▼Kein さん：
お礼遅くなりました。
大変ありがとうございあました。

ひとつ質問なんですが、コピーする際に
GetR = Application _
　　　　 .Match(C.Range("A1").Value, .Range("H:H"), 0)

ここで、取得した値にたいして、
DセルからUセルの範囲をコピーするためには
どうすればいいですか？
【38844】Re:セルの下にまとまって入れ込む
発言  ごまみそ  - 06/6/12(月) 11:16 -
引用なし
パスワード
   たびたび申し訳ございません。
【38847】Re:セルの下にまとまって入れ込む
回答  Kein  - 06/6/12(月) 14:20 -
引用なし
パスワード
   >取得した値にたいして、DセルからUセルの範囲をコピー
GetRの行で D:U 列にコピーする。ということですか ? ならば・・
>C.Copy .Cells(GetR, 8)
↓

.Cells(GetR, 4).Resize(, 18).Value = C.Value

と、変更して下さい。
【38876】Re:セルの下にまとまって入れ込む
お礼  ごまみそ  - 06/6/13(火) 12:42 -
引用なし
パスワード
   ▼Kein さん：
お礼おそくなり、申し訳ございません。
大変ありがとうございました！
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
7489 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free