[[20051127021238]]　『シート別に小分けにしたい』（えめら）　ページの最後に飛ぶ

『シート別に小分けにしたい』（えめら）

 シート1
 　　　　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ
 １　　商品	個数	業者	値段
 ２　　A3用紙	3	◎	1200
 ３　　A4用紙	1	▼	4500
 ４　　教科書	1	▼	2300
 ５　　マウス	4	◎	600
 ６　　プリンタ	1	◎	500
 ７　　パソコン	0	□	2000
 ８　　インクA	2　　　　◎	600
 ９　　インクB	0	□	500
 １０　インクC	1	□	700

 シート2　　　　　　　　　　　シート3　　　　　　　　　シート4　　　　　
 ◎業者のみの　　　　　　　　▼業者のみの　　　　　　　□業者のみの
 商品　　個数　　値段　　　　商品　　個数　　値段　　　商品　　個数　　値段

 シート1にこうゆう表があり、シート2、3、4に分けたいです。
 個数は１個だったり２個だったりします。
 ０個のときはシート2、3、4には表示させたくないです。

 こうゆうときはどうすればいいのですか？教えてください。
 Excel2003　WindowsXP

作ってみました（SHIOJII）
　Sub test()

    Dim mySH1 As Worksheet
    Dim mySH As Worksheet
    Dim myR   As Range
    Dim sh As Worksheet
    Dim myVal As Variant
    Dim i As Integer
    Dim j As Integer

    Application.ScreenUpdating = False

    ' 「シート1」以外のシートの削除
    For Each sh In ThisWorkbook.Worksheets
       If Not sh.Name = "Sheet1" Then
         Application.DisplayAlerts = False
         sh.Delete
         Application.DisplayAlerts = True
       End If
    Next

    '重複のない会社名の書き出し（Z列）
    Set mySH1 = Worksheets("Sheet1")
    Set myR = mySH1.Range("A1").CurrentRegion
        myR.Columns(3).AdvancedFilter xlFilterCopy, _
                       copytorange:=mySH1.Range("Z1"), unique:=True
        myVal = mySH1.Range("Z2", mySH1.Range("Z65536").End(xlUp)).Value

    '会社名で抽出
    For i = 1 To UBound(myVal, 1)
     'シートを追加して
     Set mySH = Worksheets.Add(after:=Sheets(Sheets.Count))
         mySH.Name = myVal(i, 1) & "のデータ"

      'オートフィルター
      With myR
         .AutoFilter field:=3, Criteria1:=myVal(i, 1)
         .Copy mySH.Range("A65536").End(xlUp)
         .AutoFilter
      End With

      '会社名の列削除、個数＝０の行削除
      With mySH
         .Columns(3).Delete
         For j = .Range("A65536").End(xlUp).Row To 2 Step -1
            If .Cells(j, 2).Value = 0 Then
               .Cells(j, 2).EntireRow.Delete
            End If
         Next j
      End With
    Next i
    mySH1.Range("Z:Z").ClearContents
    Application.ScreenUpdating = True

　End Sub

read-cnt: 45

（えめら）すみません。私パソコン初心者で・・・
これは何処に入れれば良いのですか？
Subってどうゆう意味ですか？
教えて下さい。お願い致します。

 こんにちわ

 1) エクセル画面より　Alt + F11 でVBEを起動
 2) 「挿入」 -> 「標準もジュール」,右空白部分に下記コードを貼り付ける。
 3) x をクリックしてエクセル画面に戻る
 4) 「ツール」 -> 「マクロ」 -> 「マクロ」で "test" を選択して「実行」

 Sub test()
 Dim dic As Object, w, x, y
 Dim i As Long, ii As Long
 Dim ws As Worksheet
 Set dic = CreateObject("Scripting.Dictionary")
 With Sheets("sheet1")
    a = .Range("a1").CurrentRegion.Resize(, 4).Value
 End With
 For i = 2 To UBound(a, 1)
    If Not IsEmpty(a(i, 3)) Then
        If Not dic.exists(a(i, 3)) Then
            ReDim w(3, 0)
            For ii = 0 To 3
                w(ii, 0) = a(i, ii + 1)
            Next
            dic.Add a(i, 3), w
        Else
            w = dic(a(i, 3))
            ReDim Preserve w(3, UBound(w, 2) + 1)
            For ii = 0 To 3
                w(ii, UBound(w, 2)) = a(i, ii + 1)
            Next
            dic(a(i, 3)) = w
        End If
    End If
 Next
 x = dic.keys: y = dic.items: Set dic = Nothing
 For i = 0 To UBound(x)
    On Error Resume Next
    Set ws = Sheets(x(i))
    If ws Is Nothing Then
        Set ws = Sheets.Add
        ws.Name = x(i)
    End If
    Err.Clear
    With ws.Range("a1")
        .CurrentRegion.ClearContents
        .Resize(, 4) = Application.Index(a, 1)
        .Offset(1).Resize(UBound(y(i), 2) + 1, UBound(y(i), 1) + 1) = _
        Application.Transpose(y(i))
    End With
    Set ws = Nothing
 Next
 Erase a, x, y
 End Sub
 (seiya)

(えめら)
ありがとうございます。早速やってみました！
できましたーーーありがとうございます。

しかし・・・
シート１で個数を変えるとシート２、３、４が変わってないいですが、
自動的に変わるとかできるんですか？
後、シート２、３、４には業者は表示したくないんです。
ぬくやり方とかできるんですか？

ほんと勉強不足ですみません。

 まずコードを下記に上書きしてください。
 Sub test()
 Dim dic As Object, w, x, y
 Dim i As Long, ii As Long
 Dim ws As Worksheet
 Set dic = CreateObject("Scripting.Dictionary")
 With Application
    .EnableEvents = False
    .ScreenUpdating = False
 End With
 With Sheets("sheet1")
    A = .Range("a1").CurrentRegion.Resize(, 4).Value
 End With
 For i = 2 To UBound(A, 1)
    If Not IsEmpty(A(i, 3)) Then
        If Not dic.exists(A(i, 3)) Then
            ReDim w(3, 0)
            For ii = 0 To 3
                w(ii, 0) = A(i, ii + 1)
            Next
            dic.Add A(i, 3), w
        Else
            w = dic(A(i, 3))
            ReDim Preserve w(3, UBound(w, 2) + 1)
            For ii = 0 To 3
                w(ii, UBound(w, 2)) = A(i, ii + 1)
            Next
            dic(A(i, 3)) = w
        End If
    End If
 Next
 x = dic.keys: y = dic.items: Set dic = Nothing
 For i = 0 To UBound(x)
    On Error Resume Next
    Set ws = Sheets(x(i))
    If ws Is Nothing Then
        Set ws = Sheets.Add
        ws.Name = x(i)
    End If
    Err.Clear
    With ws.Range("a1")
        .CurrentRegion.ClearContents
        .Resize(, 4) = Application.Index(A, 1)
        .Offset(1).Resize(UBound(y(i), 2) + 1, UBound(y(i), 1) + 1) = _
        Application.Transpose(y(i))
        ws.Columns(3).Delete
    End With
    Set ws = Nothing
 Next
 Erase A, x, y
 With Application
    .EnableEvents = true
    .ScreenUpdating = true
 End With
 End Sub

 次に、VBE画面上の左側にThisWorkbookというアイコンがありますのでWクリック

 Private Sub Workbook_SheetActivate(ByVal Sh As Object)
 test
 End Sub

 を貼り付け(seiya)

ありがとうございます。
ThisWorkbookというアイコンがありません。VBA上にあるんですよね？？
隠れてしまったのでしょうか？

お願い致します。

(えめら)

すみますん。ありました。頑張ってみます。
また分からなかったら教えてください。
ほんと助かりました！！

コメント返信：

[ 一覧(最新更新順) ]

[[20051127021238]] 『シート別に小分けにしたい』（えめら） ページの最後に飛ぶ

[[20051127021238]]　『シート別に小分けにしたい』（えめら）　ページの最後に飛ぶ