[[20150324152350]] 『最新情報を一番上に表示させたい』(やる気梨) ページの最後に飛ぶ

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

 

『最新情報を一番上に表示させたい』(やる気梨)

シート「1」の入力データをシート「2」、「3」等のデータを反映させたいのですが

シート「1」  
  A     B      C          D      E
1 氏名   山田 太郎  田山 郎太 

2 所属部署  経理課    営業部
3 配属日   2010/1/1   2010/1/1
4 所属部署  総務課    経理課
5 配属日   2011/1/1   2012/1/1
6 所属部署  営業部    営業部
7 配属日   2012/1/1   2014/1/1
8 所属部署  経理課
9 配属日   2015/1/1
.
.
.

シート「2」
  A    B
1 氏名   山田太郎

2 所属部署 配属日
3 経理課  2015/1/1
4 営業部  2012/1/1
5 総務課  2011/1/1
6 経理課  2010/1/1
7
8
9
.
.
.

この様にシート「1」は一番最初に所属した部署、配属日から入力し、それぞれシート「2」、シート「3」では最新の部署が常に一番上の列(この場合は3列目)に来る様に出来るでしょうか。
今はシート「2」のB1に氏名を入れたら最初に所属していた部署と配属日が来る様に「HLOOKUP」関数を使用しています。

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


これはどうでしょうか?

Sub abc()
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim d As Integer
a = 2
b = 1
Do Until a = 4
If Cells(11, 2).Value = Cells(1, a).Value Then

    Do Until Cells(b, a).Value = ""
    b = b + 1
    Loop
    b = b - 1
    d = b
    c = 13
    Do Until b < 2
    Cells(c, 2).Value = Cells(b, a).Value
    b = b - 2
    c = c + 1
    Loop
    c = 13
    b = d - 1
    Do Until b < 1
    Cells(c, 1).Value = Cells(b, a).Value
    b = b - 2
    c = c + 1
    Loop
    End If
a = a + 1
Loop
End Sub
あとはそちらの状況に合わせて調整してください。

(スズメ) 2015/03/24(火) 17:00


有難うございます。
頑張ってやってみます
(やる気梨) 2015/03/24(火) 17:13

あ、間違えた所があります。シート2のデータがシート1のデータの下にあるのかと勘違いしていました。

なので、もし、上のマクロをSheet1で実行するのであれば、Do Until b < 2の下にある、Cells(c, 2).Value = Cells(b, a).Valueを、Sheets(2).Cells(c, 2).Value = Cells(b, a).Valueに、Do Until b < 1の下にある、Cells(c, 1).Value = Cells(b, a).Valueを、Sheets(2).Cells(c, 1).Value = Cells(b, a).Valueとすればできると思います。

ただ、あなたがやっていたやりかたなら、HLOOKUP関数を使用した後に、日付をもとに降順にすればいいと思うのですが、それではだめなのでしょうか?
(スズメ) 2015/03/24(火) 17:23


少しミスがあったので修正版を記載します。こちらなら、シートがいくらあっても対応可能です。

Sub abc()

 Dim a As Integer
 Dim b As Integer
 Dim c As Integer
 Dim d As Integer
 Dim e As Integer
 a = 2
 e = 2
 Do Until e = 4
 b = 1
 Do Until a = 4
 If Sheets(e).Cells(1, 2).Value = Cells(1, a).Value Then
    Do Until Cells(b, a).Value = ""
    b = b + 1
    Loop
    b = b - 1
    d = b
    c = 2
    Do Until b < 2
    Sheets(e).Cells(c, 2).Value = Cells(b, a).Value
    b = b - 2
    c = c + 1
    Loop
    c = 2
    b = d - 1
    Do Until b < 1
    Sheets(e).Cells(c, 1).Value = Cells(b, a).Value
    b = b - 2
    c = c + 1
    Loop
    End If
a = a + 1
Loop
a = 2
e = e + 1
Loop
End Sub
あとは先ほどと同じくあなたの環境に合わせて調整をしてください。
(スズメ) 2015/03/24(火) 17:46

 シート2は、なんとなくわかりましたが、シート3って何ですか?
 で、シート2ですけど、実行タイミングは、さぁ、やるぞ!というタイミングでマクロ実行ですか?
 それとも、B1に名前が入った時に自動実行ですか?

 To (スズメ)さん

 行番号や列番号関係の変数、大昔は Integer型で宣言する習慣がありましたけど、
 今は(というか、大昔ではなくただの昔から)そうする意義が皆無で、ほんのちょっと処理効率にも悪影響。
 (処理効率に関しては顕微鏡でのぞいてわかるぐらいですが)

 というか、すべての整数はなんであれ、Long型で宣言しましょう。

 あと、中途半端なインデントは、かえって見づらい感があります。

 質問者さんは、回答側のコードを模範として勉強していかれるので、そのあたりにも留意いただければ。
 (と、偉そうなことを言いました。これは To β としての自戒のコメントでもあります)

(β) 2015/03/24(火) 17:57


 要件未確認のままですがとりあえず。

 ThisWorkbookモジュールに。

 Sheet2あるいはSheet3のB1に名前が入力されると自動実行。
 なお、Sheet2,Sheet3のA1,A2,B2 には、あらかじめタイトルが入っているものとします。

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim col As Variant
    Dim sh1 As Worksheet
    Dim nm As String
    Dim w As Variant
    Dim i As Long
    Dim x As Long
    Dim z As Long

    Application.ScreenUpdating = False

    Select Case Sh.Name
        Case "Sheet2", "Sheet3"             '★シート名は実際のものに
            Set sh1 = Sheets("Sheet1")      '★シート名は実際のものに
            With Sh
                Application.EnableEvents = False
                If Not Intersect(Target, .Range("B1")) Is Nothing Then
                    .Range("A1").CurrentRegion.Offset(2).ClearContents
                    nm = .Range("B1").Value
                    col = Application.Match(nm, sh1.Range("B1", sh1.Cells(1, Columns.Count).End(xlToLeft)), 0)
                    If IsError(col) Then
                        MsgBox nm & " は登録されていません"
                        .Range("B1").Select
                    Else
                        col = col + 1
                        z = sh1.Cells(Rows.Count, 1).End(xlUp).Row
                        If (z - 1) Mod 2 > 0 Then z = z + 1
                        ReDim w(1 To (z - 1) / 2, 1 To 2)
                        For i = 2 To z Step 2
                            x = x + 1
                            w(x, 1) = sh1.Cells(i, col).Value
                            w(x, 2) = sh1.Cells(i + 1, col).Value
                        Next
                        .Range("A3").Resize(UBound(w, 1), 2).Value = w
                        With .Range("A1").CurrentRegion
                            .Offset(2).Resize(.Rows.Count - 2).Sort Key1:=Columns("B"), Order1:=xlDescending, Header:=xlNo
                        End With
                    End If
                End If
                Application.EnableEvents = True
            End With
    End Select

 End Sub

(β) 2015/03/24(火) 19:53


シート3というのは、シート2の次に別の人物のを作るのだと思います。なので、本当はシート4もあるのかもしれません。

インテンド入れるの忘れていました。integerは確かに無駄ですがまれに役に立つときがありますよ。

誤って無限ループを作ってしまったとき、ある変数が限界を越えたときに止まってくれます。longだと止まってくれません。

なので、一応integerにしています。
将来はlongに変えるかどうかはじっくり考えたいと思います。
(スズメ) 2015/03/24(火) 20:53


 シート3が、別の人のシート、シート4がまた別の人のシートというのは、想像がついています。
 ポイントはいつ、どんなタイミングで実行するかということでしょうね。
 シート2〜シート〇まで、あらかじめ名前が入っている。で、シート1をメンテして、さぁ、実行という運用なのか
 シート2〜シート〇までのいずれかのシートで、山田さんはどうかなとか、田中さんはどうかなと、入力をした時点で
 そのシートに対して、その名前の人の履歴を降順で表示するのか。

 私がアップしたものは、後者です。

 前者の処理はもちろんできます。後ほどアップします。

 To (スズメ)さん

 なかなか、興味深い考え、承っておきます。
 たとえばエクセルのシート目いっぱい近くデータがある場合、2003ですでにInteger型変数では処理できなくなっているということも
 あわせて指摘しているつもりです。昨今のQ/Aでは、シートに5万件以上のデータがあるといった事例が少なくないですよね。

(β) 2015/03/24(火) 21:08


 シート1以外のシートにシート1の情報を反映させるパターンです。
 対象シートは、A1に"氏名" 、A2に"所属部署" 、B2に"配属日" タイトルがセットされているシートとしています。

 標準モジュールに。

 Sub Test()
    Dim col As Variant
    Dim sh1 As Worksheet
    Dim nm As String
    Dim w As Variant
    Dim i As Long
    Dim x As Long
    Dim z As Long
    Dim sh As Worksheet

    Application.ScreenUpdating = False

    Set sh1 = Sheets("Sheet1")          '★シート名は実際のものに

    For Each sh In Worksheets
        If sh.Name <> sh1.Name Then
            '処理妥当なシートかどうかのチェック
            If sh.Range("A1").Value = "氏名" And sh.Range("A2").Value = "所属部署" And sh.Range("B2").Value = "配属日" Then
                x = 0
                sh.Range("A1").CurrentRegion.Offset(2).ClearContents
                nm = sh.Range("B1").Value
                col = Application.Match(nm, sh1.Range("B1", sh1.Cells(1, Columns.Count).End(xlToLeft)), 0)
                If IsError(col) Then
                    MsgBox sh.Name & " の " & nm & " は登録されていません" & vbLf & "処理をスキップします"
                Else
                    col = col + 1
                    z = sh1.Cells(Rows.Count, col).End(xlUp).Row
                    If (z - 1) Mod 2 > 0 Then z = z + 1
                    ReDim w(1 To (z - 1) / 2, 1 To 2)
                    For i = 2 To z Step 2
                        x = x + 1
                        w(x, 1) = sh1.Cells(i, col).Value
                        w(x, 2) = sh1.Cells(i + 1, col).Value
                    Next
                    sh.Range("A3").Resize(UBound(w, 1), 2).Value = w
                    With sh.Range("A1").CurrentRegion
                        .Offset(2).Resize(.Rows.Count - 2).Sort Key1:=sh.Columns("B"), Order1:=xlDescending, Header:=xlNo
                    End With
                End If
            End If
        End If
    Next
 End Sub

(β) 2015/03/24(火) 21:35


確かに32768?を越える処理は時々ありますね。

ただ、そんな膨大な処理はたまにしかないので、越えないときはinteger、越えるときはlongにしています。面倒くさいですが。

あと、やる気梨さんから返信がないので、最初の回答で納得して、もう返信が来なさそうな感じがします。
(スズメ) 2015/03/24(火) 21:49


コメント返信:

[ 一覧(最新更新順) ]


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