[[20150828021207]] 『データ振り分け』(sariina) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『データ振り分け』(sariina)

初めて使わせていただきます。
教えてください!!
入力シートより別シートへふりわけです。
入力シート
 A B C D
日付  行き先  運転手 伝票ナンバー  
8/1 東京   あああ 546
8/3  埼玉   いいい 789
8/1  福島   ううう 654

反映シート
 
    ああs  いいい   ううう
8/1  東京         福島
8/3      埼玉

入力画面データがどんどん増える予定。
入力画面入力するだけで、
入力したら自動的に反映されるようにしたいです。
お願いします!!!

< 使用 Excel:Excel2007、使用 OS:Windows7 >


 反映シートのフィールド(列項目の「あああ」「いいい」「ううう」)は固定?
 それとも、入力シートに新しい運転手が追加されたら、それも自動で増やすの?
(稲葉) 2015/08/28(金) 08:22

 追記
 運転手が同日に複数の行き先になることはあるの?
(稲葉) 2015/08/28(金) 08:24

 ごめんなさ、手伝いたかったけど、急な仕事です。
 他の回答者の方、お願いします・・・
(稲葉) 2015/08/28(金) 08:41

 関数での回答が出るまでのつなぎで。

 "反映"シートのシートタブを右クリック、コードの表示を選び、でてきたところに以下を貼り付け。
 右上のXボタンをおしてシートに戻り、"入力"シートで追加、変更、削除を行ったうえで "反映"シートを見てください。

 8:59 "入力"シート側の入力が不完全なものは対象外にするよう、コード訂正。
    あわせて、"入力"シートの行数を A列基準で統一。

 Private Sub Worksheet_Activate()
    Dim dicNm As Object
    Dim dicDt As Object
    Dim c As Range
    Dim w As Variant

    Set dicNm = CreateObject("Scripting.Dictionary")
    Set dicDt = CreateObject("Scripting.Dictionary")

    UsedRange.ClearContents
    With Sheets("入力")
        For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Offset(, 2)
            If WorksheetFunction.CountA(c.EntireRow.Range("A1:C1")) = 3 And Not dicNm.exists(c.Value) Then dicNm(c.Value) = dicNm.Count + 1
        Next
        For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            If WorksheetFunction.CountA(c.EntireRow.Range("A1:C1")) = 3 And Not dicDt.exists(c.Value) Then dicDt(c.Value) = dicDt.Count + 1
        Next
        ReDim w(1 To dicDt.Count, 1 To dicNm.Count)
        For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Offset(, 1)
            If WorksheetFunction.CountA(c.EntireRow.Range("A1:C1")) = 3 Then w(dicDt(c.Offset(, -1).Value), dicNm(c.Offset(, 1).Value)) = c.Value
        Next
    End With

    Range("B1").Resize(, dicNm.Count).Value = dicNm.keys
    Range("A2").Resize(dicDt.Count).Value = WorksheetFunction.Transpose(dicDt.keys)
    Range("B2").Resize(UBound(w, 1), UBound(w, 2)).Value = w

 End Sub

(β) 2015/08/28(金) 08:47


 VBA
Sub test()
    Dim a, i As Long, ii As Long, w, x
    With Sheets("入力").Cells(1).CurrentRegion
        x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(3).Address & ",,,row(1:" & .Rows.Count & "))," & _
            .Columns(3).Address & ")=1," & .Columns(3).Address & ",char(2)))"), Chr(2), 0)
        a = .Value
    End With
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                ReDim w(1 To UBound(x) + 2)
                w(1) = a(i, 1)
            Else
                w = .Item(a(i, 1))
            End If
            w(Application.Match(a(i, 3), x, 0)) = a(i, 2)
            .Item(a(i, 1)) = w
        Next
        w = Application.Index(.items, 0, 0)
    End With
    With Sheets.Add.Cells(1)
        .Resize(, UBound(x) + 1).Value = x
        .Cells(1).ClearContents
        .Offset(1).Resize(UBound(w, 1), UBound(w, 2)).Value = w
        .CurrentRegion.Columns.AutoFit
    End With
End Sub
(seiya) 2015/08/28(金) 11:34

ありがとくございます。運転手が同日に二ヶ所いくときはあります。できたら、入力が少ない方がいいので、追加されたら自動でがいいです。入社しない限り増えることはないですねぇー。
よろしくlねがいします。
(sariina) 2015/08/28(金) 12:14

 出力シートのコードモジュールへ貼り付ける
 出力シートが選択される度にUpdateされる

 Private Sub Worksheet_Activate()
    Dim a, i As Long, ii As Long, w, x, temp
    With Sheets("入力").Cells(1).CurrentRegion
        x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Columns(3).Address & ",,,row(1:" & .Rows.Count & "))," & _
            .Columns(3).Address & ")=1," & .Columns(3).Address & ",char(2)))"), Chr(2), 0)
        a = .Value
    End With
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                ReDim w(1 To UBound(x) + 2)
                w(1) = a(i, 1)
            Else
                w = .Item(a(i, 1))
            End If
            temp = Application.Match(a(i, 3), x, 0)
            w(temp) = w(temp) & IIf(w(temp) <> "", "/", "") & a(i, 2)
            .Item(a(i, 1)) = w
        Next
        w = Application.Index(.items, 0, 0)
    End With
    With Cells(1)
        .CurrentRegion.ClearContents
        .Resize(, UBound(x) + 1).Value = x
        .Cells(1).ClearContents
        .Offset(1).Resize(UBound(w, 1), UBound(w, 2)).Value = w
        .CurrentRegion.Columns.AutoFit
    End With
End Sub
(seiya) 2015/08/28(金) 12:53

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.