VBAマクロでの質問になりますm_ _m

教えて下さい！！宜しくお願いいたします

エクセルファイルで1行に項目名があり2行目から3000行目くらいまでﾃﾞｰﾀがあり間に空白もあります。　これがO列まで続くシートです
同ファイル内に50程のシートがあり名前はﾊﾞﾗﾊﾞﾗです
こちらの開いている各シートの特定列をﾃﾞｰﾀが入っている最終行までをコピーして
新しいシートを作ってA列に（１ｼｰﾄ目の特定列）B列に（2ｼｰﾄ目の特定列）...右へ順番に張り付けていきたいです。


複数ｼｰﾄの特定列が　B列だけの場合

複数ｼｰﾄの特定列が　B列とC列の場合

複数ｼｰﾄの特定列が　B列とD列の場合

特定列が2列の場合はA、B列に（１ｼｰﾄ目の特定列）C、D列に（2ｼｰﾄ目の特定列）...右へ順番に張り付けていきたいです。

どうぞよろしくお願いいたします。

No.6 ベストアンサー 回答者： jmuiny 回答日時： 2017/01/12 10:04

こうですかね。

これ以上は詳しい説明がないと無理です。

Sub Sample2()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim sh3 As Worksheet, sh4 As Worksheet
Dim scnt As Integer
Dim i As Long, imax As Long
Dim row1 As Long, row2 As Long, row3 As Long
Dim col1 As Long, col2 As Long, col3 As Long
Application.ScreenUpdating = False
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "New_Sheet1"
Set sh1 = Worksheets(Worksheets.Count)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "New_Sheet2"
Set sh2 = Worksheets(Worksheets.Count)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "New_Sheet3"
Set sh3 = Worksheets(Worksheets.Count)
col2 = -1
col3 = -1
For scnt = 1 To Worksheets.Count - 3
Set sh4 = Worksheets(scnt)
row1 = 0
row2 = 0
row3 = 0
col1 = col1 + 1
col2 = col2 + 2
col3 = col3 + 2
With sh4
imax = .Cells(Rows.Count, "B").End(xlUp).Row
If .Cells(Rows.Count, "C").End(xlUp).Row > imax Then
imax = .Cells(Rows.Count, "C").End(xlUp).Row
End If
If .Cells(Rows.Count, "D").End(xlUp).Row > imax Then
imax = .Cells(Rows.Count, "D").End(xlUp).Row
End If
For i = 2 To imax
If .Range("B" & i).Value <> "" Then
row1 = row1 + 1
.Range("B" & i).Copy Destination:=sh1.Cells(row1, col1)
End If
If .Range("B" & i).Value <> "" And .Range("C" & i).Value <> "" And .Range("B" & i).Value = .Range("C" & i).Value Then
row2 = row2 + 1
.Range("B" & i & ":C" & i).Copy Destination:=sh2.Cells(row2, col2)
End If
If .Range("B" & i).Value <> "" And .Range("D" & i).Value <> "" And .Range("B" & i).Value = .Range("D" & i).Value Then
row3 = row3 + 1
.Range("B" & i).Copy Destination:=sh3.Cells(row3, col3)
.Range("D" & i).Copy Destination:=sh3.Cells(row3, col3 + 1)
End If
Next i
End With
Next scnt
Application.ScreenUpdating = True
End Sub

No.5 回答者： jmuiny 回答日時： 2017/01/11 17:31

>B列とC列同じ行にデータが入っているときです。

結局ここが正確にはわかりませんでした。

C列、D列が空白でない時処理しています。
この結果で、具体的にどうしたいのかを書いて下さい。
追加シート名は適当につけていますので、変更して下さい。

Sub Sample()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim sh3 As Worksheet, sh4 As Worksheet
Dim scnt As Integer
Dim col1 As Long, col2 As Long, col3 As Long
Application.ScreenUpdating = False
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "New_Sheet1"
Set sh1 = Worksheets(Worksheets.Count)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "New_Sheet2"
Set sh2 = Worksheets(Worksheets.Count)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "New_Sheet3"
Set sh3 = Worksheets(Worksheets.Count)
For scnt = 1 To Worksheets.Count - 3
Set sh4 = Worksheets(scnt)
With sh4
col1 = col1 + 1
.Range("B1:B" & .Cells(Rows.Count, "B").End(xlUp).Row).Copy Destination:=sh1.Cells(1, col1)
If .Range("C1").Value <> "" Then
col2 = col2 + 1
.Range("B1:C" & .Cells(Rows.Count, "C").End(xlUp).Row).Copy Destination:=sh2.Cells(1, col2)
col2 = col2 + 1
End If
If .Range("D1").Value <> "" Then
col3 = col3 + 1
.Range("B1:B" & .Cells(Rows.Count, "B").End(xlUp).Row).Copy Destination:=sh1.Cells(1, col3)
col3 = col3 + 1
.Range("D1:D" & .Cells(Rows.Count, "D").End(xlUp).Row).Copy Destination:=sh3.Cells(1, col3)
End If
End With
Next scnt
Application.ScreenUpdating = True
End Sub

No.4 回答者： jmuiny 回答日時： 2017/01/11 13:58

まだ説明不足ですよ。

B列とC列両方にデータがある場合、これを実際に何で判断したらよいのですか。
とお聞きしました。
C1が空白でなければC列もデータがあるという判断でいいですか？
C列全部を見て判断なのか、特定のセルC1だけを見ればいいのか・・
表を見ていない人にわかるように書いて下さい。

>B列とC列両方にデータがある場合は新しい別シート2に順番にコピー
コピーするのはＢ列とＣ列ですか？それともＣ列だけですか？

こちらの疑問を読むとわかって頂けると思いますが、コードを作成するというのは全ての事が明確になっていないと出来ない事です。
それはご自分でマクロを作成する場合も勿論同じです。

この回答へのお礼

度々恐縮ですm(_ _)m
補足の補足になります。

B列とC列両方にデータが入っている場合は→ B列とC列の全ての行を見て
B列とC列同じ行にデータが入っているときです。
このB列C列 共にデータが入って行だけを ２列とも別シートに反映さしたいですm(_ _)m わかり辛くすみません。 宜しくお願いします。

お礼日時：2017/01/11 15:56

No.3 回答者： fujillin 回答日時： 2017/01/11 13:18

こんにちは

他の方も同様と思いますが、ご質問文だけではなさりたいことがよくわかりませんね。

＞自分でも作れるようになりたいなと思いまして
とのことですので、まず、処理の内容を整理してみることをお勧めします。
「内容なんてちゃんとわかってるよ！」と言われそうですが、そうすることで、見落としていた組合せや、処理のルートなどが存在しないかといったことを確認することができます。

例えば、ご質問を簡略化して
「ブック内の全てのシートから指定した列を抜きだし、新しいシートに集積する」というマクロを作るとします。
その通りに機能するものができたとして、同じブックで2回、3回と実行すると思わぬことになりませんか？
（そのような使い方は絶対にしないと、はっきりしているような場合は問題ありませんが…）

ご自身で勉強なさりたいのであれば、疑問点を分解してご質問なさった方が的確な回答を得やすいと思いますし、その過程で自分で調べる方法なども身に付くものと思います。
例えば、「シートＡからシートＢへの列のコピーの方法はわかるけれど、これを全シートでやるにはどうすればよいか」といった塩梅でしょうか。
「for ～ nextで全シートを処理すれば良い」とか「for eachを利用すれば良い」などの回答があれば、それについて調べてみることで理解が深まると想像します。


などと書いているだけでは、回答にもならないので・・・

ご質問文からだと列の決め方がさっぱりわかりませんので、勝手に内容を変えて、上に例示したような「各シートから指定列（1列のみ）を集積する」という内容で簡単な例を作成してみました。
当然ながら、質問者様がなさりたいこととは異なると思いますが、何かの参考にでもなれば…
（集積用シート（=集積対象外）のシート名に接頭辞【列集積】を附すことで除外しています）

なお、以下の例では関数式などがあるとそのままコピーしますので、表示される値は変わる可能性があります。
また、セルの書式などが設定されていれば、そのままコピーされることになります。
（値だけコピーしたいような場合は、値のコピーを利用することで可能です）

Sub Sample()
Dim prompt As String, inp As String, col As Long
Dim sh As Worksheet, ds As Worksheet, sName As String
Dim rng As Range

Const pre = "【列集積】"
col = 0
prompt = "集積対象とする列を入力"

' 集積対象の列を指定
Do While col < 1
　inp = InputBox(prompt:=prompt)
　If Len(inp) = 0 Then Exit Sub
　On Error Resume Next
　　col = Columns(inp).Column
　On Error GoTo 0
　prompt = "有効な値ではありません。" & vbNewLine
　prompt = prompt & "有効な列名を入力（例：A, AA …など）"
Loop

' 集積用シートを走査（作成）
sName = pre & col
For Each sh In Worksheets
　If sh.Name = sName Then Exit For
Next sh
If sh Is Nothing Then
　Set ds = Worksheets.Add(after:=Worksheets(Worksheets.Count))
　ds.Name = sName
Else
　Set ds = sh
　ds.Cells.Clear
　ds.Activate
End If

' 指定列をコピー
Set rng = ds.Columns(1)
For Each sh In Worksheets
　If Left(sh.Name, 5) <> pre Then
　　sh.Columns(col).Copy Destination:=rng
　　Set rng = rng.Offset(, 1)
　End If
Next sh

End Sub

※ あくまでも参考例としてのサンプルですので、上例を下敷きにしたり修正したりして作ろうとなさらぬように。
　質問者様のなさりたいこと（私にはわかりませんが）とは、根本的に異なっている可能性がありますので。

この回答へのお礼

ありがとうございます！
そうですよね。 記載頂きましたコードでも勉強させて頂きますm(_ _)m

お礼日時：2017/01/11 15:42

No.2 回答者： jmuiny 回答日時： 2017/01/11 09:51

各シートがどいう特定列を持つか、というのは何で判断するのですか？

特定列がB列だけの場合　←　B1セルに入力がある
特定列がB列とC列の場合　　←　B1セルとC1に入力がある

のような具体的な説明を補足して下さい。

この回答へのお礼

ご連絡ありがとうございますm(_ _)m
説明不足でした。
１、全シートのB列だけを新しい別シート1に順番にコピー 終りです。
２、B列とC列両方にデータがある場合は新しい別シート2に順番にコピー
３、B列とD列両方にデータがある場合は新しい別シート3に順番にコピー

という事をしたいと考えています！宜しくお願いいたしますm(_ _)m

お礼日時：2017/01/11 13:04

No.1 回答者： naktak 回答日時： 2017/01/10 11:54

どこまで作ったんですか？

この回答へのお礼

ご連絡ありがとうございます。
B列が作成できて一番左のシートはコピーされるのですが、
それ以上が進まないんです！　勉強中で初歩的なことかもしれませんが今まで記録ばかりだったので自分でも作れるようになりたいなと思いまして！よろしくお願いします！

Sub B列のみ()
Dim WS As Worksheet
For Each WS In Worksheets
WS.Activate
Call Columns("B:B").Select
Selection.Copy
Worksheets.Add
ActiveSheet.Name = "B列"
Columns("B:B").Select
ActiveSheet.Paste

Next
End Sub

お礼日時：2017/01/10 15:34