No.9ベストアンサー
- 回答日時:
おはようございます。
#8です。
自身の回答を何気に読んでいたら、、、わけのわからん処理がありました。
コピペで改造したのが原因で、申し訳ないです。
下記を訂正いたします。。
2行不要です。
データを書き込む処理
For i = 0 To UBound(Itemkey)不要ですので削除
For i ループの中で変数 i が使用されていない事でも不要な処理でした。
それに対するNext(nx:の上の行)も削除してください。
ここまで書いて、気が付きました。半角全角の処理で、、
文字列が半角+全角や半角+全角+半角など、、、
Application.CountIfでは、対応できませんね。。
Itemkeyの配列に入れている文字列なので、
範囲内の一致する文字列で半角全角に対応する関数
WorksheetFunction.SumProduct,,、いけないか?たぶんレンジ
Functionを作成した方がわかり易いかも、と思いますが、他の良い方法ご存知の方、教えてください。
総当たりで配列内で数を取得します。
多分、配列の大きさもリスト作成時に取得設定できると思いますが、朝で頭が回りません。
改めて、プロシージャ挙げます。
ちなみに、営業所名、シート名にルールを決めて半角全角を混在させないで、
名簿シートなどに書き出してあればこの苦労は、無いかも知れません。
私は、むしろ、趣味なので良いのですが、、、。
Sub Sample()
Dim Key_list As New Collection
Dim myAry, Sht, KeyItem
Dim i As Long, j As Long, n As Long, ii As Long, ix As Long
Dim dataWs As Worksheet
Dim tmpAry, x As Long
Set dataWs = Worksheets("データ") 'ご質問のシート名「データ」シート
tmpAry = dataWs.Range("A2:A" & dataWs.Cells(Rows.Count, "A").End(xlUp).Row)
With dataWs
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next
Key_list.Add StrConv(UCase(.Cells(i, "A").Text), vbWide), StrConv(UCase(.Cells(i, "A").Text), vbWide) '営業所名でリストを作ります
On Error GoTo 0
Next
End With
For Each KeyItem In Key_list 'リスト内
With dataWs
ix = 0
For x = 1 To UBound(tmpAry) '配列のサイズを調べる
If KeyItem = StrConv(UCase(tmpAry(x, 1)), vbWide) Then
ix = ix + 1
End If
Next
ReDim myAry(ix, 9) '9=0~9なので10列目まで
n = 0
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If KeyItem = StrConv(UCase(.Cells(i, "A")), vbWide) Then
For j = 0 To 9
myAry(n, j) = .Cells(i, j + 1)
Next
n = n + 1
End If
Next
End With
On Error Resume Next
For Each Sht In Worksheets
If StrConv(UCase(Sht.Name), vbWide) = KeyItem Then
With Sheets(Sht.Name)
If Sht <> dataWs Then
.Cells(Rows.Count, "C").End(xlUp).Offset(1).Resize(UBound(myAry), 10) = myAry '出力
.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).RemoveDuplicates (2)
.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).Sort key1:=.Columns(4), Order1:=xlAscending
End If
End With
GoTo nx
End If
Next
nx:
Next
Set dataWs = Nothing
MsgBox ("完了")
End Sub
リストの作り方や問題点を変えましたが、ご希望の結果になりますでしょうか?
重複データを削除しているコードです
.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).RemoveDuplicates (2)
列ナンバー(2)の数値を変えると列が変わります。
Qchan1962 様
この度はわたしの我儘にお付き合い頂き有難うございました(*^^*)
無事解決いたしました。対応も素晴らしくお二方には感謝しかありません。
VBAが趣味だなんて羨ましい限りです‼
今回の件、大変ご迷惑おかけいたしました(>_<)&有難うございました。
ベストアンサーに選ばせてください。
No.12
- 回答日時:
直接の回答ではありません事お詫びします。
Qchan1962様へ
私は決してあなた様の参加に気分を害したとかは全くありません。
参加については自由なはずです。
単に
・別サイトで問題解決が進んでいる
・私の回答した内容はあくまでも営業所列は数値(シート名は数字)のみで作成したので、数値と文字列が混同しているのなら使えないな
と言う事での退散です。
なのでお気にせずにいて下さい。
めぐみん_様
この度は、前スレッドよりお付き合い頂き有難うございます。
無事問題解決いたしました。
気分を害されるような対応をしてしまっていたら大変申し訳ありませんでした。
お二方によりアドバイス頂いた解答を今後共業務に生かしていきたいと思います。
女性でプログラムを組めること、とても素晴らしく尊敬します。
ありがとうございました(*^^*)
No.11
- 回答日時:
質問者様、スレッドお借りしてすみません。
#10 めぐみん_様 へ 横から突然大変失礼をいたしました。
先の https://oshiete.goo.ne.jp/qa/11658168.html のご質問の
#8に寄せられたお礼で、こちらのスレッドを拝見し、回答しました。
先の質問後半での流れで、推測して回答を投稿した次第です。本スレッドの流れを
把握せず、いきなり回答投稿をして気分を害されたと思います。
誠に申し訳ございませんでした。
No.10
- 回答日時:
No.4に対しての回答もなくNo.5のコードを提示しましたが、
>シート名はすべて半角としていますが、R1というシートも含まれています。
と別サイトでは補足があったようで、そうなるとNo.5のコードは使えません。
以上。(別サイトで話が進んでいるようですからここで終了します。)
No.8
- 回答日時:
こんばんは、気が付きませんでした。
データシートのA列がキーでC列の古い品番に重複しないデータのみをA列営業所別のシートに振り分け
C列からL列に書き込みます。
データシートの2行目からが、対象データ
振り分け先シートは、5行目に見出しがあらかじめ書かれている。
R1の様に半角全角が混在する場合があり、文字も数値のみも混在する。
半角全角問わず同じシートに書き込まれます。(これは、ちゃんと検証していません。多分です)
例 R1 R1 同じR1シートへ
営業所名と同じ名前のシートがある事、シートが無い場合は書き込みされません。
余談ですが、 めぐみん_さんの構文の方がデータが多くある場合、とても速いですよ。(現在学習中)
>.Open ThisWorkbook.FullName
>でデバッグとなったのですが、何が原因なのでしょうか(>_<)
これ、テスト的に作成した新規ブックを保存していなかったのではないでしょうか?
.FullName なのでパスも含まれるかと思いますので。
Sub Sample()
Dim Key_list As New Collection
Dim myAry, Sht, Itemkey()
Dim i As Long, j As Long, n As Long, ii As Long
Dim dataWs As Worksheet: Set dataWs = Worksheets("データ")
With dataWs
For i = 3 To .Cells(Rows.Count, "A").End(xlUp).Row
ReDim Preserve Itemkey(ii)
On Error Resume Next
Key_list.Add StrConv(.Cells(i, "A").Text, vbWide), StrConv(.Cells(i, "A").Text, vbWide)
If Err.Number = 0 Then
Itemkey(ii) = .Cells(i, "A") ’営業所名でリストを作ります
ii = ii + 1
End If
On Error GoTo 0
Next
End With
For ii = 0 To UBound(Itemkey)
With dataWs
ReDim myAry(Application.CountIf(.Range("A:A"), Itemkey(ii)), 9) '9=0~9なので10列目まで
n = 0
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If StrConv(UCase(Itemkey(ii)), vbWide) = StrConv(UCase(.Cells(i, "A")), vbWide) Then
For j = 0 To 9
myAry(n, j) = .Cells(i, j + 1)
Next
n = n + 1
End If
Next
End With
On Error Resume Next
For i = 0 To UBound(Itemkey)
For Each Sht In Worksheets
If StrConv(Sht.Name, vbWide) = StrConv(Itemkey(ii), vbWide) Then
With Sheets(Sht.Name)
.Cells(Rows.Count, "C").End(xlUp).Offset(1).Resize(UBound(myAry), 10) = myAry
.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).RemoveDuplicates (2)
.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).Sort key1:=.Columns(3), Order1:=xlAscending
End With
GoTo nx
End If
Next
Next
nx:
Next
Set dataWs = Nothing
MsgBox ("完了")
End Sub
.Range("C6:L" & .Cells(Rows.Count, "C").End(xlUp).Row).RemoveDuplicates (2)
変な書き方ですが、.Range("C6").CurrentRegion.RemoveDuplicates (2)とすると空白列が例にありましたので
埋まっているであろう範囲を選択しました。改修時は分かり難いかも知れません。
コード作成頂き有難うございます‼感謝いたします。
試してみたところ、デバッグもなくスムーズに完了まで進むことが出来ました。ただ、品番が重複してるデータも追加されるのですが、改善できますでしょうか(>_<)
前回のスレッドよりお付き合いいただき申しわけありません。。
私のパソコンではめぐみんさんのコードにデバッグが発生しまうので、(保存場所が悪いのか?)会社の方でも双方のコードを使用し試してみたいと思います。
No.7
- 回答日時:
ちなみに過去にこの方法での回答は何度かしてますが、
>.Open ThisWorkbook.FullName
>でデバッグとなったのですが、何が原因なのでしょうか(>_<)
というのは初めて見ました。
もしMac等Win以外でやっているってなら私は未経験なので解決策は不明ですよ。
No.6
- 回答日時:
>.Open ThisWorkbook.FullName
>でデバッグとなったのですが、何が原因なのでしょうか(>_<)
そこは単純にワークブックのPath及び名前を繋げた物を得ているだけです。
なのでもしかするとアクセス出来ない(権限がない)所に保存しているのかもですね。
CドライブであればDドライブとかにしてみるか?
私はデスクトップに保存して試しましたから他に言えるとしたらフォルダ名に全角文字を使っているからかな?
それも保存先を変更して検証してください。
保存先を変えてもコードの変更は今ある情報からの判断では問題ないかと。
>のコードはそのまま使用してよかったでしょうか?
>初心者のため、何もわからず申し訳ないです、、
私もただの初級者ですが、良いかどうかはこちらではわかりません。
あくまでも情報を基にしているのであって、それ以上の事はこちらでは検証できないからです。
No.5
- 回答日時:
・個々の営業所のシート名は『営業所』の列に合わせた半角数字で成り立っている事。
・個々の営業所のC5より左にデータが存在しない事。(罫線があるのはきになるけど)
最初に『品番』が同じデータは省いてしまう方が楽でしょ。
且つ営業所の数値がシート名の数字と一致しているデータを抽出して貼り付ける。
Sub megu()
Dim objCn As Object
Dim objRS As Object
Dim ws As Worksheet
Dim strSQL As String
Dim r As Range
Dim i As Integer
Set objCn = CreateObject("ADODB.Connection")
Set objRS = CreateObject("ADODB.Recordset")
With objCn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;HDR=YES"
.Open ThisWorkbook.FullName
End With
For i = 2 To Worksheets.Count '★ 一番左がデータシートだとして
Set ws = Worksheets(i)
With ws
Set r = .Range("C5").CurrentRegion
strSQL = ""
strSQL = strSQL & " SELECT *"
strSQL = strSQL & " FROM [データ$]"
strSQL = strSQL & " WHERE [営業所] = " & Val(ws.Name) '★ シート名は半角数字である事
strSQL = strSQL & " AND NOT ([品番] IN"
strSQL = strSQL & " (SELECT 品番"
strSQL = strSQL & " FROM [" & ws.Name & "$" & r.Address(0, 0) & "]));"
Set objRS = objCn.Execute(strSQL)
r.Offset(r.Rows.Count).Resize(1, 1).CopyFromRecordset objRS
Set r = Nothing
objRS.Close
End With
Set ws = Nothing
Next
objCn.Close
Set objCn = Nothing
Set objRS = Nothing
End Sub
めぐみん_さん、コードを考えて頂きありがとうございます。感謝しております(*^^*)試してみたところ
.Open ThisWorkbook.FullName
でデバッグとなったのですが、何が原因なのでしょうか(>_<)
ちなみに、strSQL = ""
strSQL = strSQL & " SELECT *"
strSQL = strSQL & " FROM [データ$]"
strSQL = strSQL & " WHERE [営業所] = " & Val(ws.Name) '★ シート名は半角数字である事
strSQL = strSQL & " AND NOT ([品番] IN"
strSQL = strSQL & " (SELECT 品番"
strSQL = strSQL & " FROM [" & ws.Name & "$" & r.Address(0, 0) & "]));"
のコードはそのまま使用してよかったでしょうか?
初心者のため、何もわからず申し訳ないです、、
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) vbaエクセルマクロ RemoveDuplicatesについて RemoveDuplicatesを使 3 2023/02/28 01:13
- Visual Basic(VBA) vbaエクセルマクロ RemoveDuplicatesについて RemoveDuplicatesを使 1 2023/02/27 22:21
- Excel(エクセル) Excelマクロ 差分抽出の方法が知りたいです。 2 2023/03/07 13:25
- Visual Basic(VBA) Excel vbaについて知恵もしくは、コード教えて下さいm(__)m ① 表にあるデータをコピー、 2 2022/09/01 23:57
- Excel(エクセル) 【困っています】VBA 追加処理の記述を教えてください。 1 2022/08/25 22:54
- Excel(エクセル) VBA セルの値と同じ名前のシートにデータを貼り付けするやり方を教えてください 2 2022/05/17 16:26
- Visual Basic(VBA) エクセル VBA 処理スピードを上げたいのですが。 6 2023/03/31 20:52
- Visual Basic(VBA) 【ご教示ください】VBAの記述方法がわかりません。 2 2022/08/12 21:28
- Excel(エクセル) Excelマクロの差分抽出のコードを教えていただきたいです。 2 2023/03/14 11:40
- Visual Basic(VBA) 【困っています2】VBA 追加処理の記述を教えてください。 2 2022/08/26 11:42
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
マクロの「SaveAs」でエラーが...
-
マクロ実行後に別シートの残像...
-
VBA 空白行に転記する
-
EXCELのSheet番号って変更でき...
-
Count Ifのセルの範囲指定に変...
-
VBA別シートの最終行の次行へ転...
-
VBA 別ブックからの転記の高速...
-
【VBA】特定の条件でセルをコピー
-
【Excel VBA】自動メール送信の...
-
100万件越えCSVから条件を満た...
-
Excel2013で切り取り禁止
-
RemoveDuplicatesメソッドにつ...
-
検索して修正したデータの上書転記
-
VBAコードについて
-
VBA webクエリをループさせる...
-
エクセルVBAで他のbookのセ...
-
Excel VBA オートフィルターで...
-
Unionでの他のシートの参照につ...
-
Changeイベントで複数セルへの...
-
VBAでのピボットテーブルの範囲...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
マクロの「SaveAs」でエラーが...
-
マクロ実行後に別シートの残像...
-
VBAコードについて
-
VBA 空白行に転記する
-
EXCELのSheet番号って変更でき...
-
VBA 別ブックからの転記の高速...
-
【VBA】特定の条件でセルをコピー
-
VBA別シートの最終行の次行へ転...
-
100万件越えCSVから条件を満た...
-
VBAで変数の数/変数名を動的に...
-
Changeイベントで複数セルへの...
-
楽天RSSからエクセルVBAを使用...
-
Count Ifのセルの範囲指定に変...
-
Unionでの他のシートの参照につ...
-
Excel2013で切り取り禁止
-
Excel VBA オートフィルターで...
-
VBA 実行時エラー1004 rangeメ...
-
複数シートの複数列に入力され...
-
VBA Userformで一部別シートに...
-
ExcelのVBマクロを、バックグラ...
おすすめ情報