Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


6824 / 13644 ツリー ←次へ | 前へ→

【42805】抽出結果を別シートに保存 トホホ 06/9/22(金) 13:08 質問[未読]
【42806】Re:抽出結果を別シートに保存 ハチ 06/9/22(金) 14:49 回答[未読]
【42906】Re:抽出結果を別シートに保存 トホホ 06/9/25(月) 10:41 質問[未読]
【42907】Re:抽出結果を別シートに保存 ハチ 06/9/25(月) 11:00 発言[未読]
【42911】Re:抽出結果を別シートに保存 トホホ 06/9/25(月) 12:30 質問[未読]
【42913】Re:抽出結果を別シートに保存 トホホ 06/9/25(月) 12:47 発言[未読]
【42916】Re:抽出結果を別シートに保存 ハチ 06/9/25(月) 13:18 発言[未読]
【42917】Re:抽出結果を別シートに保存 トホホ 06/9/25(月) 13:25 発言[未読]
【42924】Re:抽出結果を別シートに保存 トホホ 06/9/25(月) 14:22 お礼[未読]
【42833】Re:抽出結果を別シートに保存 Hirofumi 06/9/23(土) 0:41 回答[未読]

【42805】抽出結果を別シートに保存
質問  トホホ  - 06/9/22(金) 13:08 -

引用なし
パスワード
   商品分類 商品 品番 得意先 数量
LLL    **  **** ****** *
MMM    **  **** ****** *
SSS    **  **** ****** *
     ・
     ・
     ・
     ・
というようなDBがあります。(ちなみに約20000件のレコード)
このDBから、商品分類をキーにしてフィルタで抽出し
結果を、元DBのあるxls.ブックの別シートに貼りつけ、シート名は
抽出キーである商品分類にするというマクロを実行したいのですが・・・。
●抽出キーのあるフィールドは常に○列目とは限りません。
●また、分類も今回の例の様に毎回LLLとMMMとSSSとは
限りません。

↓の様に書いてみたのですが、問題があります。
1.毎回抽出キーが違うので替わるたびにシート名もマクロの中で
書き換える必要がある。商品分類の数は数十種類。
2.あらかじめ、商品分類の名前でシートを用意しておくのが手間。
3.下の記述を見ても分かるが、同じような記述を繰り返しているが
もっとスマートにしたい。
どなたかよいお知恵があれば教えてください。
よろしくお願いします。


Sub 抽出_商品分類()
  With Worksheets("受注DB").Range("A1")
   .AutoFilter Field:=4, Criteria1:="LLL"
   .CurrentRegion.SpecialCells(xlVisible).Copy Worksheets("LLL").Range("A1")
   .AutoFilter
  End With
  Worksheets("LLL").Activate
  With Worksheets("受注DB").Range("A1")
   .AutoFilter Field:=4, Criteria1:="MMM"
   .CurrentRegion.SpecialCells(xlVisible).Copy Worksheets("MMM").Range("A1")
   .AutoFilter
  End With
  Worksheets("MMM").Activate
  With Worksheets("受注DB").Range("A1")
    .AutoFilter Field:=4, Criteria1:="SSS"
  .CurrentRegion.SpecialCells(xlVisible).Copy Worksheets("SSS").Range("A1")
    .AutoFilter
  End With
  Worksheets("SSS").Activate
End Sub

【42806】Re:抽出結果を別シートに保存
回答  ハチ  - 06/9/22(金) 14:49 -

引用なし
パスワード
   ▼トホホ さん:

>●抽出キーのあるフィールドは常に○列目とは限りません。
>●また、分類も今回の例の様に毎回LLLとMMMとSSSとは
>限りません。
>↓の様に書いてみたのですが、問題があります。
>1.毎回抽出キーが違うので替わるたびにシート名もマクロの中で
>書き換える必要がある。商品分類の数は数十種類。

キーの位置、分類の文字列も不定となると抽出したいモノは
どこかに羅列(セルでもコード内でもいいですけど)する必要があります。

>2.あらかじめ、商品分類の名前でシートを用意しておくのが手間。

これは、マクロでやれば良いですね。
Sheet名にできない文字列がきたときにどうするのか? とか
今回抽出条件に当てはまってないSheetはどうするのか?(古いデータのまま?) とか
というのは別に考えておく必要があると思います。

>3.下の記述を見ても分かるが、同じような記述を繰り返しているが
>もっとスマートにしたい。

こちらは引数で渡して処理するようにすれば良いです。

mainのところにズラズラと羅列する形になります。

Option Explicit

Sub main()
  抽出 "LLL", 4
  抽出 "MMM", 4
  '・・・・
  '・・・・
End Sub

'分類=分類を文字列で指定。項目=列番号を数字で指定
Private Sub 抽出(分類 As String, 項目 As Integer)
  Dim Org_Sh As Worksheet '元Sheet
  Dim Des_Sh As Worksheet '先Sheet
  '元SheetをSet
  Set Org_Sh = Worksheets("受注DB")
  '先SheetをSet なければ作成。
  On Error Resume Next
    Set Des_Sh = Worksheets(分類)
  On Error GoTo 0
  If Des_Sh Is Nothing Then
    Set Des_Sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    Des_Sh.Name = 分類
  Else
    Des_Sh.Cells.Clear
  End If
  'AutoFilterでコピー
  With Org_Sh.Range("A1")
   .AutoFilter Field:=項目, Criteria1:=分類
   .CurrentRegion.SpecialCells(xlVisible).Copy Des_Sh.Range("A1")
   .AutoFilter
  End With
  
  Set Org_Sh = Nothing
  Set Des_Sh = Nothing
End Sub

【42833】Re:抽出結果を別シートに保存
回答  Hirofumi  - 06/9/23(土) 0:41 -

引用なし
パスワード
   受注DBには、列見出しが有る物とします
抽出Keyの位置は、rngListを基準とした列Offsetとします
例えば、A1(列見出し「商品分類」)を基準とすると、A列は0、B列は1、C列は2
実行時に抽出Keyで整列され終了直前に元の行位置に再整列されます

Option Explicit

Public Sub Sample()

  '結果出力の先頭位置
  Const cstrTop As String = "A1"
  
  Dim i As Long
  Dim lngRows As Long
  Dim lngColumns As Long
  Dim lngTop As Long
  Dim lngCount As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim rngHeader As Range
  Dim vntGroup As Variant
  Dim vntKeys As Variant
  Dim vntColumnWidth As Variant
  Dim strProm As String

  'Listの先頭セル位置(左上隅)を基準とする(列見出し「商品分類」のセル位置)
  Set rngList = Worksheets("受注DB").Cells(1, "A")

  '抽出Keyの有る列を指定(rngListで指定した列を基準とした列Offset値)
  strProm = "抽出Keyの有る列を指定して下さい(基準位置からの列Offset値)"
  vntKeys = Application.InputBox(strProm, , 0, , , , 1)
  If VarType(vntKeys) = vbBoolean Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngList
    '列数の取得
    lngColumns = .Offset(, Columns.Count - .Column) _
              .End(xlToLeft).Column - .Column + 1
    If lngColumns <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, vntKeys).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成
    ReDim vntData(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      vntData(i, 1) = i
    Next i
    '復帰用Keyの出力
    .Offset(1, lngColumns) _
          .Resize(lngRows).Value = vntData
    'データを抽出Keyで整列
    DataSort .Offset(1).Resize(lngRows, _
          lngColumns + 1), .Offset(, vntKeys)
    '抽出Keyデータを配列に取得
    vntGroup = .Offset(1, vntKeys) _
              .Resize(lngRows + 1).Value
    '列見出し範囲を取得
    Set rngHeader = .Resize(, lngColumns)
    '列幅を取得
    ReDim vntColumnWidth(lngColumns - 1)
    For i = 0 To lngColumns - 1
      vntColumnWidth(i) _
          = .Offset(, i).EntireColumn.ColumnWidth
    Next i
  End With
  
  '仮に結果と元表を同じにして置く
  Set rngResult = rngList
  '注目値の位置を記録
  lngTop = 1
  'データ行数のカウント初期値
  lngCount = 1
  For i = 2 To lngRows + 1
    '注目値と現在値が違った場合
    If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
      '出力シートを設定
      GetSheets CStr(vntGroup(lngTop, 1)), cstrTop, _
            rngResult, rngHeader, vntColumnWidth
      'データを転記
      rngList.Offset(lngTop).Resize(lngCount, _
            lngColumns).Copy Destination:=rngResult
      '注目値の位置を記録
      lngTop = i
      'データ行数のカウント初期値に
      lngCount = 1
    Else
      'データ行数のカウントを更新
      lngCount = lngCount + 1
    End If
  Next i

  With rngList
    '元データを復帰
    DataSort .Offset(1).Resize(lngRows, _
          lngColumns + 1), .Offset(1, lngColumns)
    '復帰用Key列を削除
    .Offset(, lngColumns).EntireColumn.Delete
  End With
   
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
   
  Set rngList = Nothing
  Set rngResult = Nothing
  Set rngHeader = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

Private Sub GetSheets(strName As String, _
            strTop As String, _
            rngResult As Range, _
            rngHeader As Range, _
            vntWidth As Variant)
  
  Dim i As Long
  Dim lngRows As Long
  Dim wksMark As Worksheet
  
  'シートの存在確認
  For Each wksMark In Worksheets
    If StrComp(wksMark.Name, strName, vbTextCompare) = 0 Then
      Exit For
    End If
  Next wksMark
  'もし、シートが無いなら
  If wksMark Is Nothing Then
    'シートを追加して、シート名を設定
    Set wksMark = Worksheets.Add(After:=rngResult.Parent)
    On Error Resume Next
    wksMark.Name = strName
    On Error GoTo 0
  End If
  
  With wksMark.Range(strTop)
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      '列幅を設定
      For i = 0 To UBound(vntWidth, 1)
        .Offset(, i).EntireColumn.ColumnWidth = vntWidth(i)
      Next i
      '列見出しを出力
      rngHeader.Copy Destination:=.Offset
      '出力位置を設定
      Set rngResult = .Offset(rngHeader.Rows.Count)
    Else
      '出力位置を設定
      Set rngResult = .Offset(lngRows + 1)
    End If
  End With
  
  Set wksMark = Nothing
      
End Sub

【42906】Re:抽出結果を別シートに保存
質問  トホホ  - 06/9/25(月) 10:41 -

引用なし
パスワード
   ありがとうございます。
早速トライしてみようと思ったのですが、
下の様に記述するとエラーになりました。
何が間違っているのでしょうか?

Option Explicit
Sub main()
  抽出 "LLL", 1
  抽出 "MMM", 1
  抽出 "TTT", 1
End Sub

'分類=分類を文字列で指定。項目=列番号を数字で指定
  Private Sub 抽出(商品分類 As String, 1 As Integer)'ここがコンパイルエラー
  Dim Org_Sh As Worksheet '元Sheet
  Dim Des_Sh As Worksheet '先Sheet
  '元SheetをSet
  Set Org_Sh = Worksheets("元DB")
  '先SheetをSet なければ作成。
  On Error Resume Next
    Set Des_Sh = Worksheets(商品分類)
  On Error GoTo 0
  If Des_Sh Is Nothing Then
    Set Des_Sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    Des_Sh.Name = 商品分類  Else
    Des_Sh.Cells.Clear
  End If
  'AutoFilterでコピー
  With Org_Sh.Range("A1")
   .AutoFilter Field:=1, Criteria1:=商品分類   .CurrentRegion.SpecialCells(xlVisible).Copy Des_Sh.Range("A1")
   .AutoFilter
  End With
 
  Set Org_Sh = Nothing
  Set Des_Sh = Nothing
End Sub

【42907】Re:抽出結果を別シートに保存
発言  ハチ  - 06/9/25(月) 11:00 -

引用なし
パスワード
   ▼トホホ さん:
>ありがとうございます。
>早速トライしてみようと思ったのですが、
>下の様に記述するとエラーになりました。
>何が間違っているのでしょうか?
>
>Option Explicit
>Sub main()
>  抽出 "LLL", 1
>  抽出 "MMM", 1
>  抽出 "TTT", 1
>End Sub
>
>'分類=分類を文字列で指定。項目=列番号を数字で指定
>  Private Sub 抽出(商品分類 As String, 1 As Integer)'ここがコンパイルエラー

ここは"項目" という変数に引数の2つ目の数値を受け取っています。
変数名"1"を作れないからコンパイルエラーになります。
"項目" のままやれば良いです。

AutoFilterをかける列は、ずれることがある となっていたので
引数で受け取るようにしてました。
念の為、
Private Sub 抽出(ByVal 商品分類 As String, ByVal 項目 As Integer)
のほうが良いかも。

【42911】Re:抽出結果を別シートに保存
質問  トホホ  - 06/9/25(月) 12:30 -

引用なし
パスワード
   ありがとうございます。
マクロが終了し、今回は6種類のキーで
抽出した結果、6枚新規シートが作成されました。
が・・・。
なぜか"SL"を除くどの抽出結果シートにも"31"と"51"を含むレコードが
あるのです。試しに手で抽出したのですが、
その場合はきれいに結果が出ました。
どうして、関係ない"31"と"51"分類のレコードが一緒に抽出されるので
しょうか?
ちなみに"31"と"51"のフィールドは数値を文字列として
入力しています。


Option Explicit
Sub main()
  抽出 "SL", 1
  抽出 "31", 1
  抽出 "51", 1
  抽出 "4K", 1
  抽出 "DH", 1
  抽出 "P1", 1
End Sub

'分類=分類を文字列で指定。項目=列番号を数字で指定
Private Sub 抽出(ByVal SYOHIN As String, ByVal 項目 As Integer)
  Dim Org_Sh As Worksheet '元Sheet
  Dim Des_Sh As Worksheet '先Sheet
  '元SheetをSet
  Set Org_Sh = Worksheets("RE_CALCU")
  '先SheetをSet なければ作成。
  On Error Resume Next
    Set Des_Sh = Worksheets(SYOHIN)
  On Error GoTo 0
  If Des_Sh Is Nothing Then
    Set Des_Sh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    Des_Sh.Name = SYOHIN
  Else
    Des_Sh.Cells.Clear
  End If
  'AutoFilterでコピー
  With Org_Sh.Range("A1")
   .AutoFilter Field:=項目, Criteria1:=SYOHIN
   .CurrentRegion.SpecialCells(xlVisible).Copy Des_Sh.Range("A1")
   .AutoFilter
  End With
 
  Set Org_Sh = Nothing
  Set Des_Sh = Nothing
End Sub

【42913】Re:抽出結果を別シートに保存
発言  トホホ  - 06/9/25(月) 12:47 -

引用なし
パスワード
   >なぜか"SL"を除くどの抽出結果シートにも"31"と"51"を含むレコードが
>あるのです。試しに手で抽出したのですが、
>その場合はきれいに結果が出ました。

大変失礼しました。
全ての抽出結果シートに"31"と"51"を含むレコードが
くっついていました。
どうしておこる現象なのでしょうか?
何度もすみませんm(__)m

【42916】Re:抽出結果を別シートに保存
発言  ハチ  - 06/9/25(月) 13:18 -

引用なし
パスワード
   ▼トホホ さん:
>>なぜか"SL"を除くどの抽出結果シートにも"31"と"51"を含むレコードが
>>あるのです。試しに手で抽出したのですが、
>>その場合はきれいに結果が出ました。
>
>大変失礼しました。
>全ての抽出結果シートに"31"と"51"を含むレコードが
>くっついていました。
>どうしておこる現象なのでしょうか?
>何度もすみませんm(__)m

CurrentRegionの考慮漏れだと思います。失礼しました。
AutoFilterでコピーのところを↓に差し替えてください。

  'AutoFilterでコピー
  With Org_Sh.UsedRange
   .AutoFilter Field:=項目, Criteria1:=SYOHIN
   .SpecialCells(xlVisible).Copy Des_Sh.Range("A1")
   .AutoFilter
  End With

【42917】Re:抽出結果を別シートに保存
発言  トホホ  - 06/9/25(月) 13:25 -

引用なし
パスワード
   私がああでもないこうでもない・・・とやっているときに
早速お返事いただきました。
ありがとうございます。m(__)m
下記の様に書き換えました。
混ざることもなく抽出されましたが、
結果は"31"と"51"シートは見出し行のみになりました。
何がおかしいのでしょう??


>CurrentRegionの考慮漏れだと思います。失礼しました。
>AutoFilterでコピーのところを↓に差し替えてください。
>
>  'AutoFilterでコピー
>  With Org_Sh.UsedRange
>   .AutoFilter Field:=項目, Criteria1:=SYOHIN
>   .SpecialCells(xlVisible).Copy Des_Sh.Range("A1")
>   .AutoFilter
>  End With

【42924】Re:抽出結果を別シートに保存
お礼  トホホ  - 06/9/25(月) 14:22 -

引用なし
パスワード
   ハチさん

本当にありがとうございます。
上手くいきました。
何度も何度も根気よく教えてくださって
ありがとうございました。

本当にすっきりしました。
ありがとうございました。

6824 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free