[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『順々にオートフィルタをかけ別シートへ転記』（たたたたたた）
VBA初心者でございます。
ご教授いただきたく投稿いたします。
「元データ」というシートに1行目が項目行で、a列～G列まである表があります。
G列にて順々にフィルタをかけたデータを、
「転記先」シートへ上から順々に転記したいです。
https://www.excel.studio-kazu.jp/kw/20160107102118.html
こちらで回答があったコードを加工しながら試したのですが、
うまくいきませんでした。
引用のコードでは、フィルタをかけたコピーデータが貼り付け先シートに都度
置き換わる形になるのですが、置き換えではなく、
貼り付け先シートの最終行に都度、追記していく形にしたいです。
つたないご説明で恐縮ですが、よろしくお願いいたします。
＜ 使用 Excel：Excel2010、使用 OS：Windows10 ＞
とりあえず、A～G列ってことは7項目あるんですよね
どの列（の項目）でフィルタしたデータを、貼り付け先シートの最終行に都度、追記したいのでしょうか？
ご質問によっては、丸ごとコピーして並べ替えするだけで良さそうな気がします。
（もこな２） 2018/01/17(水) 15:32
>G列にて順々にフィルタをかけたデータ >置き換えではなく、 >貼り付け先シートの最終行に都度、追記していく形にしたいです。
う～ん、文面を見る限り私もG列で並べ替えしたらいいのではないかと思いますが… （コナミ） 2018/01/17(水) 15:42
Sub Sample()
'==変数の宣言とか
Dim コピー先 As Worksheet
Set コピー先 = ThisWorkbook.Worksheets("転記先")
Dim 条件 As Variant '抽出条件を配列で格納するための変数を用意
Dim i As Integer
'
'==主処理
'抽出条件を配列に格納
条件 = Array("い", "は", "ほ", "と")
With ThisWorkbook.Worksheets("元データ")
'項目を「転記先」の１行目にコピー
コピー先.Range("A1:G1").Value = .Range("A1:G1").Value
'オートフィルタが設定されてたら解除
If .AutoFilterMode Then .Range("A1").AutoFilter
'抽出条件を切り替えながらループ
For i = 0 To UBound(条件)
.Range("A1").AutoFilter Field:=7, Criteria1:=条件(i)
.Range("A2", .Cells(Rows.Count, "G").End(xlUp)).Copy _
コピー先.Cells(コピー先.Cells(Rows.Count, "G").End(xlUp).Row + 1, "A")
Next i
End With
End Sub
（もこな２） 2018/01/17(水) 16:18
説明下手で色々くみ取って頂き申し訳ないです。
本投稿では、局所的なマクロ動作に関してご質問させていただきました。
大枠でやりたい作業としては、2ブック間の金額突合作業です。
2ブックとも表の構成は同じで、
a～g列までありまして、項目名はa列から順に、
日付、商品名、数量、単価、金額、税、会社名の並びになっております。
共通キーとなる項目がなく、今は突合用ブックを別に作り、
元の2ブックから突合用ブックへ転記し、突合をしております。
突合用ブックの構成は、
2行目が項目行で、a～g列は元ブック1の転記用の列で、
I～O列は元ブック2の転記用の列になっております。
また、Q～T列は数量、単価、金額、消費税の差額で、
C列～F列とK列からN列の差額が出るような数式を入れております。
日付がニアリーでQ～T列の誤差がなければ、マッチと判定しています。
2ブックをそれぞれ別の人間が作成しておりまして、
同じ商品データであっても、日付が1，2日異なっていたり、
会社名の法人格が「(株)」、機種依存の「（株）」、「株式会社」で異なっていたりと、
共通キーがないので、手作業でやっている現状です。
全てマクロでというのは、今の自分では荷が重すぎますので、
こういう考え方をすれば工数削減できるといったアドバイスでも頂ければ幸いでございます。
＞徐々にフィルタをかけたデータってなんですか？
データ量が多く、いちいちフィルタを掛けなおしてコピペするのが大変な状況です。
なので、自動でフィルタを掛けなおしてコピペができればと思いました。
＞ご質問によっては、丸ごとコピーして並べ替えするだけで良さそうな気がします。
ちょっと自分が作業を難しく考えすぎていただけかもしれませんので、
こちらのやり方も踏まえて、自分でも考えてみます。
（たたたたたた） 2018/01/17(水) 17:59
共通のキーとなるものがないとなると。。なかなか難しいですね。
エクセル君はあいまい検索（1文字違っててもＯＫとか、空白入っててもＯＫ）っていう処理は苦手なので、重複排除後の会社数にもよりますけど、思い切ってリストだけ（データ側はもちろんいじっちゃダメですよね）「(株)」、機種依存の「（株）」、「株式会社」は全部取っ払って、純粋な会社名だけにしてから、オートフィルタで部分一致で抜き出してコピーして、ってやれば多少は楽になる。。。かも。（要は、株式会社鈴木、(株)鈴木も、鈴木（カ も「鈴木」というキーワードで引っかけるというイメージ）
ただ、これだと、関係ない鈴木建設 とかあったらそれも拾っちゃいますよね・・・・
※（半角・全角）、（大文字・小文字）はオートフィルタで区別しないってできと思いますし、ダメでも変換する関数あるのでそこは心配はないとおもいますけど。。
（もこな２） 2018/01/19(金) 17:53
こんばんは！
二つのデータを比較して重複しているものを抽出先に転記します。
商品名 数量 単価 金額 税 会社名でユニークなKeyを作成していますので
データによっては全くヒットしないかもしれません汗
エラー処理とかはしていません。
何かのヒントになれば幸いです。
でも、ヒットすればかなりの確率で同じデータであると言える？でしょう？？？
最終的に転記するデータはMyBのデータです。
上手く行くといいですね
頑張って下さいね
では、では、
Option Explicit
Sub てすと()
Dim MyA As Variant
Dim MyB As Variant
Dim MyArry() As Variant
Dim MyDic As Object
Dim 商品名 As String
Dim 会社名 As String
Dim ユニークなKey As String
Dim i As Long
Dim j As Long
Dim k As Long
'ディクショナリーの生成
Set MyDic = CreateObject("Scripting.Dictionary")
'Sheet1に二つのBookのデータがあるとしてそれぞれ配列に取得します。
With Sheets("Sheet1")
MyA = .Range("A2").CurrentRegion.Value
MyB = .Range("I2").CurrentRegion.Value
End With
k = 1
ReDim MyArry(1 To UBound(MyA, 2), 1 To k)
For j = LBound(MyA, 2) To UBound(MyA, 2)
MyArry(j, k) = MyA(1, j)
Next
For i = LBound(MyA, 1) To UBound(MyA, 1)
'条件を増やしてください
'取り敢えず商品名は半角に変換します
商品名 = StrConv(MyA(i, 2), vbNarrow)
'会社名から株式会社 株 ?梶@(株) は削除します
会社名 = Replace(Replace(Replace(Replace(StrConv(MyA(i, 7), vbNarrow), _
"株式会社", ""), "株", ""), "??", ""), "(株)", "")
'商品名 数量 単価 金額 税 会社名でユニークなKeyを作成
ユニークなKey = 商品名 & MyA(i, 3) & MyA(i, 4) & MyA(i, 5) & MyA(i, 6) & 会社名
MyDic(ユニークなKey) = MyA(i, 1)
Next
For i = LBound(MyB, 1) + 1 To UBound(MyB, 1)
'条件を増やしてください
'取り敢えず商品名は半角に変換します
商品名 = StrConv(MyB(i, 2), vbNarrow)
'会社名から株式会社 株 ?梶@(株) は削除します
会社名 = Replace(Replace(Replace(Replace(StrConv(MyB(i, 7), vbNarrow), _
"株式会社", ""), "株", ""), "??", ""), "(株)", "")
'ユニークなKeyが重複していたら
ユニークなKey = 商品名 & MyB(i, 3) & MyB(i, 4) & MyB(i, 5) & MyB(i, 6) & 会社名
If MyDic.Exists(ユニークなKey) Then
'日付が空白ではなかったら
If MyDic(ユニークなKey) <> Empty Then
'日付を比較 2日 以内だったら
If Abs(Val(MyB(i, 1)) - Val(MyDic(ユニークなKey))) <= 2 Then
'kをインクリメント
k = k + 1
'配列を拡張して
ReDim Preserve MyArry(1 To UBound(MyB, 2), 1 To k)
'対象データをMyArryに転記
'ここまで一致しているとかなり同じデータである可能性が高いです。
'MyBのデータを取得します。
For j = LBound(MyB, 2) To UBound(MyB, 2)
MyArry(j, k) = MyB(i, j)
Next
End If
End If
End If
Next
Application.ScreenUpdating = False
'抽出先にも見出しはあるものとして下に順次転記していきます。
With Sheets("抽出先")
.Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(UBound(MyArry, 2), UBound(MyArry, 1)).Value = Application.Transpose(MyArry)
Application.Goto .Range("A" & .Rows.Count).End(xlUp).Offset(1)
.Range("A1").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
Set MyDic = Nothing
Erase MyA, MyB, MyArry
MsgBox "処理が完了しました"
End Sub
寝る前にIphoneで見たらあまりにも可読性が悪いのでちょっと修正です。
すみません
おやすみなさい 2018/01/20 01:26
（SoulMan） 2018/01/19(金) 23:37
もこな２様
＞共通のキーとなるものがないとなると。。なかなか難しいですね。
おっしゃる通りで悪戦苦闘しております。
転記元ブックと転記先ブックでそれぞれ社名でソートをかけ、
可視セル同士でコピペができれば早いんですが、
そういったことはできないみたいです。
SoulMan様
＞商品名 数量 単価 金額 税 会社名でユニークなKeyを作成していますので
照合フォーマットを設計する上で当初マクロ作成まで視野に入れていなかったもので、
変な項目キーになってしまっています。。
まさか構文まで作成いただけるとは思っていませんでしたので、大変感謝です！
素人なりに、一つ一つの構文を消化させながら、テスト検証をしてみます。
また、行き詰った際は、ご相談させていただきますm(__)m
お二方ともありがとうございました。
（たたたたたた） 2018/01/23(火) 09:12
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.