[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『データ振り分け』(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
出力シートのコードモジュールへ貼り付ける 出力シートが選択される度に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.