VBAでの新規シート作成について

VBA初心者です。Excel2007、XPを使用しています。

シート1のA列からH列まで、数千行データがあります。
1行目は見出しです。

その中でG列に値が入っている、且つH列に指定文字以外の時、
D～Hを新規シートに表示したいです。

(例)
D　/　E　/　F　/　G　/　H
ID　/　名前　/　品名　/　文言　/　メーカー
123456　/　名前1　/　　/　A社
678910　/　名前2　/　○　/　B社
111213　/　名前3　/　　/　C社
141516　/　名前4　/　×　/　D社


→新規シート[B社]
678910　/　名前2　/　○　/　B社

→新規シート[D社]
141516　/　名前4　/　×　/　D社


こういった動作は可能でしょうか。
恐れ入りますが、ご教授お願い致します。

質問者からの補足コメント

• 

  大変失礼致しました。
  例文に追加致します。
  
  (例)
  指定文字「E社」「F社」「G社」
  
  D　/　E　/　F　/　G　/　H
  ID　/　名前　/　品名　/　文言　/　メーカー
  123456　/　名前1　/　　/　A社
  678910　/　名前2　/　○　/　B社
  111213　/　名前3　/　　/　C社
  141516　/　名前4　/　×　/　D社
  171819　/　名前5　/　△　/　E社
  
  
  →新規シート[B社]
  678910　/　名前2　/　○　/　B社
  
  →新規シート[D社]
  141516　/　名前4　/　×　/　D社
  
  宜しくお願い致します。

    補足日時：2015/09/05 08:54

No.3 ベストアンサー 回答者： soixante 回答日時： 2015/09/07 00:35

補足を拝見しました。

ちょっとこれでも良く分かりませんが、つまり、

・G列に値が入っている
・H列が「E社」「F社」「G社」ではない

この二つを満たす場合に、D～H列を新規シートに、ということですね。
転記する新規シートはどこなのか、という条件が分かりませんが、例示によると、H列の値を
シート名とするシート、ということでいいんでしょうか。

D～H列まで５項目ありますが、データが４つしかないのは何か意味はありますか。
＞678910　/　名前2　/　○　/　B社


ざっくりでいえば、以下の方針で可能と思われます。

１．シート1の2行目から最終行までのループ
２．各行ごとにIf文で条件分岐
　　G列が空白でない　かつ　H列が指定文字ではない
３．上記のIf文を満たしたら、転記すべきシート名を取得
　　（H列の値？）
４．転記すべきシートが決まったら、そのシートの最終行を取得
５．そこにコピペ
６．繰り返し

この回答へのお礼

ご返事が大変遅くなり、申し訳ございません。
拙い説明に、ご丁寧にご教授いただき、ありがとうございます。
私の力不足でまだ思った形にできませんが、
参考にさせて頂いております。
本当にありがとうございます。

お礼日時：2015/09/17 12:48

No.4 回答者： moto_koukousei 回答日時： 2015/09/08 17:52

私もあまり詳しくないし、数年前に使わなくなって遠ざかっていたので、スマートなやり方は出来ません。

試しに思い出しながら試行錯誤したら、動くモノが出来たので、参考になればと書きます。
～～～～
条件　win7、excel2007、
メモリ　実験したらexcelで400MBを越えると、不安定になりました。
次の実験は安定的に動きました。結果的にexcelの使用メモリは140MBくらいです。これを保存するファイルサイズは3.3MBくらいです。
～～～～
仮定条件　
１）あらかじめ｢Sheet1｣シートが出来ていて、データが入っている
２）あらかじめ｢除外指定｣シートに除外するべき指定文字列が入っている
３）他にシートは存在しない（社名シートはコードで新造する）
４）データの条件
4-1)　｢Sheet1｣シートのデータ行数は3万行程度
4-2）社名は数十社程度　（400社、500社でも動くことは動く）
4-3) ｢Sheet1｣シートのG列には、空白行、文字行など数値以外の行もある
4-4) ｢Sheet1｣シートのＨ列で、《指定文字列以外》となるモノは多数あるし、《指定文字列》は10種類くらいある
～～～～
実験では次のコードで、Sheet1に仮データ29999行と、｢除外指定｣シートに13種の文字列を作りました。

Sub 実験データを作る()
Randomize
With Sheets("Sheet1")
For i = 1 To 8
.Cells(1, i) = Chr(64 + i)
Next i
tb = .Range("A1:H30000")
For i = 2 To 30000
tb(i, 2) = Int(Rnd() * 10000 + 38)
tb(i, 3) = Int(Rnd() * 100) * 1000
kari = "ID_" & Right("000000" & Int(1000000 * Rnd()), 6)
kari = Left(kari, 4) & Chr(64 + Mid(kari, 5, 1)) & _
Mid(kari, 6, 6)
tb(i, 4) = kari
tb(i, 5) = "ほみにか" & i - 1 & "名前"
tb(i, 6) = Rnd()
If tb(i, 6) < 0.54 Then
tb(i, 6) = Int(Rnd() * 1000) * 100
ElseIf tb(i, 6) < 0.77 Then
tb(i, 6) = "○"
ElseIf tb(i, 6) < 0.92 Then
tb(i, 6) = "×"
Else
tb(i, 6) = ""
End If
tb(i, 7) = Chr(64 + Int(Rnd() * 16)) _
& Mid(Rnd(), 3, 1) & "社"
tb(i, 8) = "文字列" & Int(Rnd() * 54 + 1)
Next i
.Range("A1:H30000") = tb
Worksheets.Add(after:=Worksheets("Sheet1")).Name = "除外指定"
Sheets("除外指定").Cells(1, 1) = "除外するべき指定文字列"
For i = 2 To 14
Cells(i, 1) = Sheets("Sheet1").Cells(5 + i, 8)
Next i
End With
End Sub
　～～～～
上のコードで作ったデータを対象にして、下のコードで、『Sheet1の行で（G列に値が入っている、且つ、H列に指定文字以外の値が入っている）行を、
社名毎の新規シートに、それぞれの社名に合わせて』転写出来ました。

Sub 対象をシートにコピーする()
' F列(A列から6フィールド目)が数値である行だけを表示させる(AutoFilter)
Sheets("Sheet1").AutoFilterMode = False
Set myrange = Sheets("Sheet1").Range("F:F")
myAns = ">=" & Application.WorksheetFunction.Min(myrange)
Sheets("Sheet1").Range("A:H").AutoFilter _
field:=6, Criteria1:=myAns
' H列の文字列が、
'　　(｢除外指定｣シートのA列2行目から下にある文字列には該当しない)行だけを
'　表示させて、その結果を仮設作業シートにコピーし、G列の社名の辞書を作り
'　（社名毎のシートを新造追加し、仮設作業シートを社名でAutoFilterした結果を
' 　社名シートにコピーし、AutoFilterを解除する）のを繰り返す
With Sheets("除外指定")
gte = .UsedRange.Rows.Count
gt = .Range("A2:A" & gte)
End With
Randomize
ksh = "仮設作業シート" & Right(Rnd(), 3)
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = ksh
With Sheets("Sheet1")
Dim a
a = Application.Transpose(.Range("H2:H" & _
.Range("H60000").End(xlUp).Row).Value)
For i = 1 To gte - 1
a = Filter(a, gt(i, 1), False)
Next i
.Range("A:H").AutoFilter field:=8, Criteria1:=a, Operator:=xlFilterValues
End With
Sheets("Sheet1").Range("A1").CurrentRegion.Copy Sheets(ksh).Range("A1")
Sheets("Sheet1").AutoFilterMode = False
DoEvents
With Sheets(ksh)
Dim Dic
Set Dic = CreateObject("Scripting.Dictionary")
On Error Resume Next
rr = Sheets(ksh).UsedRange.Rows.Count
For i = 2 To rr
sya = .Cells(i, 7).Value
Dic.Add sya, sya
Next i
mSyasuu = Dic.Count
mSyamei = Dic.keys
For i = 0 To mSyasuu
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = mSyamei(i)
Sheets(ksh).AutoFilterMode = False
Sheets(ksh).Range("A:H").AutoFilter field:=7, Criteria1:=mSyamei(i)
Sheets(ksh).Range("A1").CurrentRegion.Copy Sheets(mSyamei(i)).Range("A1")
Next i
Sheets(ksh).AutoFilterMode = False
End With
End Sub

条件設定が違うと手直しが必要になりますが、似たような処理で出来ると想像します。

No.2 回答者： hallo-2007 回答日時： 2015/09/05 11:43

毎回、会社ごとに新規のシートを作成していたらシートが増えて大変になりますよ。

一案ですが
抽出シート

　　A　　　　B
　メーカー　文言
　B社　　　="<>"

ID　　名前　　品名　　文言　　メーカー

と抽出するシートを準備して
A2セルに抽出する社名を入れたら、以下に条件になったデータが抽出される方法が便利だと思います。

簡単に、フィルターオプションの機能を使って出来ます
フィルターオプションについては
http://www.eurus.dti.ne.jp/yoneyama/Excel/vba/vb …
のあたりでも参考にしてください。
この方法で、抽出出来たら、マクロの記録でコードが作成できます。
後は、そのコートをシートモジュールにコピーして使用すれば
A2セルを変更するだけですぐに希望の表が出来ます。
うまくいったら、マクロの記録で出来たコードでも提示してみてください。

No.1 回答者： soixante 回答日時： 2015/09/04 20:34

指定文字「以外」ですか？

例示されているのだと、H列のデータを名前とするシートに転記するように見えます。
もう少し詳しく補足されると有用な回答が付きそうです。