特定文字列から空白セルまでの抽出２

質問

下例のようなエクセル変換された表があります。この表の「会社A」のデータ（A3：J5）、「会社B」のデータ（A8:J9）を抽出し、それぞれ「会社A」「会社B」という別シートに貼り付けたいです（実際はA、B２社ではなく１０社以上あります）。特定文字列から空白行までの行数は変動します。前に似た質問がありましたが、初心者ゆえ理解出来ず、うまく活用出来ませんでした。よろしくお願い致します。

　　　A　　　　　B　　　　C　　　　D　　　　E　　　　F　　　　G　　　　H　　　　I　　　　J
１　コード　　 品名 数値(1) 数値(2) 数値(3) 数値(4) 数値(5) 数値(6) 数値(7) 数値(8)
２　会社A
３　000-000　品A　　456　　　789　　123　　　456　　　789　　　123　　456　　　789
４　000-001　品B　　456　　　789　　123　　　456　　　789　　　123　　456　　　789
５　000-002　品C　　456　　　789　　123　　　456　　　789　　　123　　456　　　789
６
７　会社B
８　000-000　品A　　456　　　789　　123　　　456　　　789　　　123　　456　　　789
９　000-003　品D　　456　　　789　　123　　　456　　　789　　　123　　456　　　789
１０
１１

回答No.1

tom04 · ベストアンサー

こんばんは！
データは会社ごとにまとまっていて、必ず空白行がある訳ですよね？

VBAになってしまいますが・・・
一例です。
（1）Sheet1に元データがあり会社名が入ったSheetがすべて整っている。
（2）各会社Sheetの1行目は同じタイトル行が入っている。
という二点の前提です。

Alt＋F11キー　→　画面左下の「This Workbook」をダブルクリック！
VBE画面に↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub 振り分け() 'この行から
Dim i, k As Long
Dim str As String
Dim ws As Worksheet
Set ws = Worksheets(1)
Application.ScreenUpdating = False
ws.Columns(1).Insert
For i = 2 To ws.Cells(Rows.Count, 2).End(xlUp).Row
If WorksheetFunction.CountA(ws.Rows(i)) = 1 Then
str = ws.Cells(i, 2)
ElseIf ws.Cells(i, 2) <> "" Then
ws.Cells(i, 1) = str
End If
Next i
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
For k = 2 To Worksheets.Count
If ws.Cells(i, 1) = Worksheets(k).Name Then
Range(ws.Cells(i, 2), ws.Cells(i, 11)).Copy Destination:= _
Worksheets(k).Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
Next k
Next i
ws.Columns(1).Delete
Application.ScreenUpdating = True
End Sub 'この行まで

ご希望の方法でなかったらごめんなさいね。m(_ _)m

お礼

早速の御返答ありがとうございます！
無事、この方法で解決致しました。
あまりの早さに、初心者としては驚くばかりです…。

わがままついでなのですが…。

sheet1及び、会社名sheetの
１行目を空けて、２行目にタイトル行をもってくると、
どう変わりますでしょうか？

また、正確に言いますと、エクセル変換されたsheet１の会社名は
[000-000000　△△商事ＤＧ　　　　]
のようになっているため、社名をsheet名にそのまま使うことが出来ません。
（カッコがsheet名では使えないため）
何か良い方法はありますでしょうか？
今のままでも、sheet１を少し加工すれば出来るのですが(^^;

始めから正確にお伝えすべきところ、申し訳ありません。

回答No.5

tom04

No.1です。

お礼欄の2点について・・・

＞１行目を空けて、２行目にタイトル行をもってくると、
どう変わりますでしょうか？

に関してはFor～Nextの最初の行番号を変えるだけで対応できます。

＞sheet１の会社名は
[000-000000　△△商事ＤＧ　　　　]
のようになっているため、

の件が問題ですので、もう一度コードを作ってみました。
↓の画像のような配置で社名も画像のようになっているとします。
今回はSheetを最終Sheet以降に追加して社名を入れるようにしてみましたので、
Sheet名を入れる必要はありません。

社名A列が
[000-000000 △△商事ＤＧ　　　　]
のようになっている場合は「△△商事ＤＧ」をSheet名にするようにしています。
前回同様Alt＋F11キー　→　This Workbook　のVBE画面に↓のコードをコピー＆ペーストして
マクロを実行してみてください。

Sub 振り分け() 'この行から
Dim i, j, k, N As Long
Dim str1, str2, buf As String
Dim ws As Worksheet
Set ws = Worksheets(1)
Application.ScreenUpdating = False
ws.Columns("A:B").Insert
For i = 3 To ws.Cells(Rows.Count, 3).End(xlUp).Row
If WorksheetFunction.CountA(ws.Rows(i)) = 1 Then
str1 = StrConv(WorksheetFunction.Substitute(WorksheetFunction.Substitute( _
ws.Cells(i, 3), "[", ""), "]", ""), vbNarrow)
ElseIf ws.Cells(i, 3) <> "" Then
For j = 1 To Len(str1)
str2 = Mid(str1, j, 1)
If Not str2 Like "[0-9,-]" Then
buf = buf & str2
End If
Next j
End If
If ws.Cells(i, 3) <> "" Then
ws.Cells(i, 2) = Trim(buf)
If WorksheetFunction.CountIf(ws.Columns(1), Trim(buf)) = 0 Then
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = Trim(buf)
End If
End If
buf = ""
Next i
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
For k = 2 To Worksheets.Count
If ws.Cells(i, 1) = Worksheets(k).Name Then
N = N + 1
End If
Next k
If N = 0 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = ws.Cells(i, 1)
End If
N = 0
Next i
For k = 2 To Worksheets.Count
If WorksheetFunction.CountA(Worksheets(k).Rows(2)) = 0 Then
Range(ws.Cells(2, 3), ws.Cells(2, 12)).Copy Destination:=Worksheets(k).Cells(2, 1)
Else
j = Worksheets(k).Cells(Rows.Count, 1).End(xlUp).Row
If j > 2 Then
Worksheets(k).Rows(3 & ":" & j).Delete
End If
End If
Next k
For k = 2 To Worksheets.Count
For i = 4 To ws.Cells(Rows.Count, 2).End(xlUp).Row
If ws.Cells(i, 2) = Worksheets(k).Name Then
Range(ws.Cells(i, 3), ws.Cells(i, 12)).Copy Destination:= _
Worksheets(k).Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
Next i
Next k
ws.Columns("A:B").Delete
Application.ScreenUpdating = True
End Sub 'この行まで

※　今回はSheet1のデータが変わるたびに何度マクロを実行しても重複表示しないようにしてみました。
※　For～Nextを多用していますので、若干時間がかかるかもしれません。
参考になりますかね？m(_ _)m

お礼

修正して頂き、ありがとうございます。

このマクロはうまくいきませんでした。
最初の１社目の社名がシート名になり追加されますが、
そのシートに全てのデータが移ってしまいます。
シートは１つしか作成されません…。

が、その前に私の補足が間違っておりました(泣)

社名は
[000-000000]　△△商事DG　　　
という表示でした。
大変申し訳ありません。

また、私の都合を付け加えますと
全社ではなく、数社のデータを抜粋して
シートに移したいため
最初にお教え頂いたマクロが使いやすいです。

いろいろと考えて頂きありがとうございました。

回答No.4

KURUMITO

回答No3です。B1セルの会社名が気になるのでしたらセルの書式設定で文字の色を白色にすればよいでしょう。

回答No.3

KURUMITO

会社名をシート名にすることはできないとのことですね。
次のようにしてはどうでしょう。
お示しのデータがシート1に有るとします。
初めに、シート見出しでSheet2からSheet12までをShiftキーを押しながらクリックして同じ作業グループにします。それらのすべてのシートが選択状態のシートになります。
そこでアクティブな状態にあるシート2のA1セルにはシート1に出てくる最初の会社名（例えば会社A）を入力します。B1セルにはその次に出てくる会社名（例えば会社B）を入力します。
A2セルからJ2セルまでには項目名を入力します。
A3セルには次の式を入力してJ3セルまでオートフィルドラッグコピーしたのちに下方にもオートフィルドラッグコピーします。

=IF(OR(COUNTIF(Sheet1!$A:$A,$A$1)=0,COUNTIF(Sheet1!$A:$A,$B$1)=0),"",IF(ROW(A1)>=MATCH($B$1,Sheet1!$A:$A,0)-MATCH($A$1,Sheet1!$A:$A,0),"",IF(INDEX(INDEX(Sheet1!$A:$J,MATCH($A$1,Sheet1!$A:$A,0)+1,1):INDEX(Sheet1!$A:$J,MATCH($B$1,Sheet1!$A:$A,0)-1,10),ROW(A1),COLUMN(A1))=0,"",INDEX(INDEX(Sheet1!$A:$J,MATCH($A$1,Sheet1!$A:$A,0)+1,1):INDEX(Sheet1!$A:$J,MATCH($B$1,Sheet1!$A:$A,0)-1,10),ROW(A1),COLUMN(A1)))))

これでシート2には最初の会社についてのデータが表示されます。
その後にシート1を選択します。これで先に設定したシートの作業グルーが解除されます。
シート2からシート1２までには最初の会社のデータが表示されています。シート2はそのままでよいのですがシート3から以降のシートではA1セルには表示したい会社名を、B1セルにはシート1のA列で表示したい会社名の次に並ぶ会社名を入力します。そのことでA1セルに入力した会社のデータが表示されます。

回答No.2

noname#204879

添付図参照
１．「エクセル変換された表」が Sheet1 にあり、それぞれの会社名（会社A、会社B、…）をシート名とする別のシートを用意して、このブックに[名前を付けて保存]
２．各会社のシートのセル A2 に次の配列数式を入力して、此れを右方および下方にドラッグ＆ペースト
　　　{=IF(ROW(A1)<MATCH(TRUE,OFFSET(INDIRECT("Sheet1!A"&MATCH(MID(CELL("filename",A1),FIND("]",CELL("filename",A1))+1,10),Sheet1!$A:$A,0)),0,0,100,)="",0)-1,OFFSET(INDIRECT("Sheet1!A"&MATCH(MID(CELL("filename",A1),FIND("]",CELL("filename",A1))+1,10),Sheet1!$A:$A,0)),ROW(A1),COLUMN(A1)-1),"")}

お礼

ご回答ありがとうございます！

ＶＢＡでしか出来ないと思っていましたが
このようなやり方もあるんですね。

正直、驚きました。

この度は、ＶＢＡをよく知らない私でも
ＶＢＡで解決してしまいましたが、
今後の参考にさせて頂きたいと思います。

画像まで添付して頂き、非常に分かりやすかったです。

ありがとうございました！