Excel VBA質問箱 IV

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

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


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

【38403】シート間で同条件の並べ替え ピッコロ 06/6/1(木) 23:27 質問[未読]
【38411】Re:シート間で同条件の並べ替え Statis 06/6/2(金) 9:26 発言[未読]
【38474】Re:シート間で同条件の並べ替え ピッコロ 06/6/3(土) 18:28 質問[未読]
【38482】Re:シート間で同条件の並べ替え ナイスプログラム 06/6/3(土) 23:25 回答[未読]
【38495】Re:シート間で同条件の並べ替え Statis 06/6/5(月) 9:14 発言[未読]
【38520】Re:シート間で同条件の並べ替え ピッコロ 06/6/5(月) 17:40 質問[未読]
【38535】Re:シート間で同条件の並べ替え Statis 06/6/6(火) 9:46 発言[未読]
【38521】Re:シート間で同条件の並べ替え ナイスプログラム 06/6/5(月) 17:46 発言[未読]
【38528】Re:シート間で同条件の並べ替え ナイスプログラム 06/6/5(月) 19:26 回答[未読]
【38530】Re:シート間で同条件の並べ替え ナイスプログラム 06/6/6(火) 0:10 回答[未読]
【38729】Re:シート間で同条件の並べ替え ピッコロ 06/6/9(金) 9:04 お礼[未読]
【38500】Re:シート間で同条件の並べ替え ハチ 06/6/5(月) 12:43 発言[未読]

【38403】シート間で同条件の並べ替え
質問  ピッコロ  - 06/6/1(木) 23:27 -

引用なし
パスワード
   Private Sub Worksheet_Change(ByVal Target As Range)
MsgBox Target.Address
If Target.Offset(2, 0).Value = "合計" Then
      Worksheets("DB").Range("A1").Sort Key1:=Worksheets_             ("DB").Columns("B"), Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,        SortMethod:=xlPinYin
End If
End Sub
お世話になっております
DBシートには電話番号、氏名、住所、品名が入力されており
電話番号順に整理されています。
しかし集計シートには各個人の品名の個数を確認したいため
集計シートには電話番号や住所は無く名前の順番がバラバラです。

そこでシート間でDBシートと同条件の並べ替えをしたいと思い集計シートモジュールに
上記のようなコードを組んでみましたが,これではDBシートが並べ替えられてしまいます。

シート間で同条件で並べ替える方法があればご教授お願いします。

【38411】Re:シート間で同条件の並べ替え
発言  Statis  - 06/6/2(金) 9:26 -

引用なし
パスワード
   こんにちは
良く解かりませんが
項目で集計シートにあってDBシートに無いものはありますか?
無いものが無いなら、コピーで対応できると思いますが?

なぜ、記載のイベントで対応使用としているのでしょうか?
また、一度集計シートの並び替えをマクロの記録で行ってみては如何ですか?
なぜ上手く行かないか解かると思います。

【38474】Re:シート間で同条件の並べ替え
質問  ピッコロ  - 06/6/3(土) 18:28 -

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

こんにちは
>良く解かりませんが
返事が遅くなり申し訳ありません
まだまだVBA初心者ですので、本を読んで
「ああいうことができるんじゃないか?」
と思いながら本に書いてあるコードに対し改造・もしくはコードを追加しているので
わかりづらいんじゃないかと思っています。

>項目で集計シートにあってDBシートに無いものはありますか?
---------DBシート--------
TEL          氏名    住所     日時         商品名
011-881-3456    稲本誠一    札幌市    2006/5/31 11:03    バナナ
03-1231-5432    辻本順二    東京都    2006/6/1 16:16    バナナ
06-6444-7890    藤本幸三    大阪市    2006/6/1 10:23    りんご
092-419-1942    宮元征四    福岡市    2006/5/31 17:00    りんご
------集計シート--------

    りんご    バナナ    みかん    ぶどう    合計
稲本誠一                    
辻本順二                    
藤本幸三                    
宮本征四                    
合計                    
----------------


>無いものが無いなら、コピーで対応できると思いますが?
>なぜ、記載のイベントで対応使用としているのでしょうか?

シートとしては
DBシート(最新の履歴)と確認シート(表の仕様は同じでDBの日時の過去履歴を残したもの)と集計シート(上記のような品名の数を入力するシート)を準備し作っています。

このマクロの全体的な話を申しますと
DBシートに作成してあるコマンドボタンを押すとユーザーフォームが立ち上がり、
そのユーザーフォームの項目通り入力していけばDBシートに反映される形式をとっています。

---------DBワークシートモジュール----------------
Private Sub Worksheet_Change(ByVal Target As Range)
    行 = Range(シート下端).End(xlUp).Row
    名前行 = Range("C65536").End(xlUp).Row
    
    a = Target.Row
    b = Target.Column
    MsgBox Target.Address
        
    If Target.Address = "$C$" & 名前行 Then
        MsgBox Target.Address
        Intersect(Target, Range("C1:C" & 名前行)).Copy
        MsgBox Target.Address
        Worksheets("集計").Range("A65536").End(xlUp).Offset_
        (-1).Insert
        
    End If
    If b <> 6 Then Exit Sub
    
    If b = 6 Then
      
      Intersect(Range("B" & a, "F" & a), Range("B1:F" & 行)).Copy
      Worksheets("確認").Range("B" & a, "F" & a).Insert
      Application.CutCopyMode = False
            
    End If
Emd Sub

他のシートに対してはDBシートに入力されたデータに従い、
DBシートのデータをコピーし確認シートに挿入という形をとっています。
仕様が同じ確認シートはWorksheet_Changeイベントで対応することにより、
電話番号順通り並べ替えられた為DBシートの名前をコピーし
集計シートに名前を挿入することから記載のイベントでも対応できると思い対応しています。


>また、一度集計シートの並び替えをマクロの記録で行ってみては如何ですか?
>なぜ上手く行かないか解かると思います。

単に並び替えだけでなく、もちろんマクロの記録もしながら
オプションのユーザー設定リストからの並び替えも使用してみたのですが
-------------------------------
    Sheets("DB").Select
    Application.AddCustomList ListArray:=Array("TEL", "011-881-3456", _
    "03-1231-5432", "06-6444-7890", "092-419-1942")
  Range("A1").Select
----------------------------------
集計シートに電話番号がないせいか電話番号順通りできませんでした。
その為理由としては「項目がないから上手くいかない」位しかわかりません。

配列を指定するArray関数で範囲(Range("B1:B5")のように)を取得できないのですか?

長々と書いてスイマセン。

【38482】Re:シート間で同条件の並べ替え
回答  ナイスプログラム WEB  - 06/6/3(土) 23:25 -

引用なし
パスワード
   ▼ピッコロ さん:

 今晩は。

 方法はいろいろ有ると思うのですが、私は、こういった場合、いつもDBシート全部
を配列に入れて、名前の列を、ループで1つずつチェックしながら重複がなければ新しい集計シートに記入すると言う方法を取ります。また、同時に集計も行います。

【38495】Re:シート間で同条件の並べ替え
発言  Statis  - 06/6/5(月) 9:14 -

引用なし
パスワード
   こんにちは
私にはよく理解が出来ません。
簡単に言うと、「DBシート」のシートの内容を「集計シート」で
集計したいと言うことですか?
名前と商品名でと言う事かな?

【38500】Re:シート間で同条件の並べ替え
発言  ハチ  - 06/6/5(月) 12:43 -

引用なし
パスワード
   DBシート、集計シートのIV列を使ってVLOOKUPで並び替えてみました。
集計する必要があるのならあんまり意味ないですね^^

Sub test()

Dim LastR As Range

Set LastR = Worksheets("DBシート").Range("B65536").End(xlUp)

'Work列の挿入 DBシートの名前がB列、Work列をIV列
Worksheets("DBシート").Range("B1", LastR).Offset(, 254).Formula = "=Row()"
'集計シートにVLOOKUP挿入
With Worksheets("集計シート").Range("A1", Worksheets("集計シート").Range("A65536") _
.End(xlUp)).Offset(, 255)
  .Formula = "=VLOOKUP(A1,DBシート!$B$1:" & LastR.Offset(, 254).Address & ",255,0)"
  .Value = .Value
End With
'ソート
Worksheets("集計シート").Cells.Sort Key1:=Range("IV1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
    :=xlPinYin
'Work削除
Worksheets("DBシート").Columns("IV").Delete
Worksheets("集計シート").Columns("IV").Delete

Set LastR = Nothing

End Sub

【38520】Re:シート間で同条件の並べ替え
質問  ピッコロ  - 06/6/5(月) 17:40 -

引用なし
パスワード
   ▼Statis さん:
>こんにちは
>私にはよく理解が出来ません。
>簡単に言うと、「DBシート」のシートの内容を「集計シート」で
>集計したいと言うことですか?
>名前と商品名でと言う事かな?

説明が下手ですいません
集計シートで名前の並べ替え(稲本、辻本・・・)を行う際
できればDBシートの名前が電話番号順で並んでいるように、
集計シートでもDBシートの電話番号順で名前の並べ替えを行いたいです。

ちなみに並べ替えというのはシートに項目がないと無理なのでしょうか?

【38521】Re:シート間で同条件の並べ替え
発言  ナイスプログラム WEB  - 06/6/5(月) 17:46 -

引用なし
パスワード
   ▼ピッコロ さん:

今日は。
1つ問題点に気づいたのですが、同姓同名の顧客が居た場合、集計表に電話番号がないと
見分けが付きません。必要ではないでしょうか。

【38528】Re:シート間で同条件の並べ替え
回答  ナイスプログラム WEB  - 06/6/5(月) 19:26 -

引用なし
パスワード
   今晩は。
良かったら参考にして下さい。バグがあるかも知れないので、いろいろテストして見て
下さい。


Option Explicit
Option Base 1

Dim sinki As Object
Dim vv As Variant

Public Sub db()

Dim i As Integer, ir As Integer, ic As Integer
ir = 1: ic = 1
Dim b As Boolean

vv = ThisWorkbook.Worksheets("DBシート").Range("a1").CurrentRegion.Value

Workbooks.Add
Set sinki = ActiveWorkbook

Cells(1, 1).Value = vv(1, 1)
Cells(1, 2).Value = vv(1, 2)

For i = 2 To UBound(vv, 1)
  
  If vv(i, 1) <> Cells(ir, 1) Or vv(i, 2) <> Cells(ir, 2) Then
    ir = ir + 1
    Cells(ir, 1).Value = vv(i, 1)
    Cells(ir, 2).Value = vv(i, 2)
  End If
  
  b = False: ic = 3
  
  Do While Cells(1, ic).Value <> ""
  
    If Cells(1, ic).Value = vv(i, 5) Then
      b = True
      Exit Do
    End If
    
    ic = ic + 1
  Loop
  
  If b = False Then Cells(1, ic).Value = vv(i, 5)
  Cells(ir, ic).Value = Cells(ir, ic).Value + 1
  
Next

End Sub

【38530】Re:シート間で同条件の並べ替え
回答  ナイスプログラム WEB  - 06/6/6(火) 0:10 -

引用なし
パスワード
    今晩は。

 バグがありました。同じ電話番号で名前が違う人が互い違いに複数並んでいると、
重複して集計シートに写してしまいます。先にDBシートの名前をソートして、次に
電話番号をソートしてから動かせばこの問題は起こりません。

 うまくいかない例
TEL          氏名    住所    日時    商品名
011-881-3456     稲本誠一    札幌市    2006/5/31 11:03    バナナ
011-881-3456     稲本誠    札幌市    2006/5/31 11:03    いちご
011-881-3456     稲本誠一    札幌市    2006/5/31 11:03    バナナ
011-881-3456     稲本誠    札幌市    2006/5/31 11:03    いちご

 うまく行く例
TEL          氏名    住所    日時    商品名
011-881-3456     稲本誠    札幌市    2006/5/31 11:03    いちご
011-881-3456     稲本誠    札幌市    2006/5/31 11:03    いちご
011-881-3456     稲本誠一    札幌市    2006/5/31 11:03    バナナ
011-881-3456     稲本誠一    札幌市    2006/5/31 11:03    バナナ

【38535】Re:シート間で同条件の並べ替え
発言  Statis  - 06/6/6(火) 9:46 -

引用なし
パスワード
   ▼ピッコロ さん:
こんにちは
>集計シートで名前の並べ替え(稲本、辻本・・・)を行う際
>できればDBシートの名前が電話番号順で並んでいるように、
>集計シートでもDBシートの電話番号順で名前の並べ替えを行いたいです。

DBシートの項目名前で「フィルタオプション」で重複なしで抽出して
集計シートにコピーしれば良いのでは。集計はコピーされたデータを
元にループにて集計していけば良いのではないです?

並び替えする必要が無いのでは(集計シートに名前が元々あったとしても
クリアして再度コピーです)
ただ、その元々あった名前だけの集計なら少し違いますが。

【38729】Re:シート間で同条件の並べ替え
お礼  ピッコロ  - 06/6/9(金) 9:04 -

引用なし
パスワード
   返事が遅くなり申し訳なく思っています。
私の説明不足や勉強不足のところもあり
提示していただいたコードが反映されてませんが
ナイスプログラムさんが発言されていたように配列でDBシート全体を取得しました。
そして集計シートの名前の左横の列に電話番号の列を挿入し
電話番号の列を非表示とすることにより
画面表示としては自分が思うようになったと思います。
(コードに関しては満足でない腑に落ちないところが一箇所あり妥協しましたが・・・)

下記のコード関してご指摘があれば嬉しく思います。

Sub test2()
  Dim 行, 名前セル, 電話セル
  行 = Range("F65535").End(xlUp).Row
  名前セル = Range("C65535").End(xlUp)
  電話セル = Range("B65535").End(xlUp)
  
  ReDim Arrange(行, 6)
  Dim 集計行, tel_number
  Dim sh1, sh3
  Dim i, j
  
  Set sh1 = Worksheets("DB")
  Set sh3 = Worksheets("集計")
  
  For i = 1 To 行
    For j = 1 To Columns("F").Column
      Arrange(i, j) = sh1.Cells(i, j).Value
      If Arrange(i, j) = 名前セル Then
        
        sh1.Range(Cells(i, j), Cells(i, j - 1)).Copy
        sh3.Activate
        Columns("A:A").EntireColumn.Hidden = False
        sh3.Range("A65536").End(xlUp).Offset(1).Insert
        
        集計行 = sh3.Range("B65536").End(xlUp).Row - 1
        
        Range("B" & 集計行).Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
         
          With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
          End With
          With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlHairline
          End With
        
        sh3.Range(Cells(集計行, 3), Cells(集計行 + 1, 7)).Select
          With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlHairline
          End With
          With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
          End With
          With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
          End With
          With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
          End With
          With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlDouble
            .Weight = xlThick
          End With
          
        
        sh1.Activate
        Application.CutCopyMode = False
      
      
      End If
    Next
  Next
      If Arrange(行, 2) = 電話セル Then


          sh1.Range("A1").Sort _
            Key1:=sh1.Columns("B"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            SortMethod:=xlStroke
        
          Application.AddCustomList ListArray:=sh1.Range(sh1.Cells(1, 2), sh1.Cells(行, 2))
          tel_number = Application.CustomListCount
          
          sh3.Activate
          sh3.Range(sh3.Cells(1, 1), sh3.Cells(集計行, 7)).Sort _
            Key1:=sh3.Range("A1"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=tel_number, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            SortMethod:=xlStroke
          
          Columns("A:A").EntireColumn.Hidden = True
          Application.DeleteCustomList ListNum:=tel_number

      End If
End Sub

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