Excel VBA質問箱 IV

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

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


48618 / 76732 ←次へ | 前へ→

【33049】Re:データの入れ替え
回答  Hirofumi  - 05/12/30(金) 16:57 -

引用なし
パスワード
   ★不明な点
1、データシートのシート名とListの行位置?
  → シート名を"Sheet1"、「列A:氏名」をA1のセル位置とする
2、「シート名:一覧」の表の位置?
  → 列見出し「氏名」のセル位置をA1とする
3、データシートの整列の有無?
  → マクロ中で氏名昇順の課題番号昇順の項目昇順の作業日付昇順に整列させる
4、データシートの作業日付、「シート名:一覧」の日付の型?
  → 共にシリアル値とし、データシートは"yyyy/m/d"、「シート名:一覧」はd"日"とする
5、「シート名:一覧」の各項目が予め書かれているか?
  → マクロ実行時に各項目も作成する
6、「シート名:一覧」のカレンダが予め書かれているか?
  → マクロ実行時にカレンダも作成する
7、カレンダの日付を連続とするか?、必要な日付だけ表示するか?
  → データシートの日付のMin月の1日〜Max月の末日まで連続して表示
8、使用方法として、マクロ実行時に「シート名:一覧」へ追加していくのか?、常に新規に作り直すのか?
  → マクロ実行時に、常に新規に作り直す
上記で位置関係を除き、如何するに因ってコードが大幅に変わると思います

上記の不明点を矢印以降で補った例を以下にUpします

Option Explicit

Public Sub Sample()

  'データ列数を設定
  Const clngColumns As Long = 6
  '日付の先頭列位置(「一覧」の先頭A列から数えて何番目)
  Const clngDayTop As Long = 5
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim vntDayMax As Variant
  Dim vntDayMin As Variant
  Dim vntComp As Variant
  Dim lngRow As Long
  Dim strProm As String
  
  'データListの左上隅セル位置を基準として設定(列見出しの最左セル位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  
  '一覧の左上隅セル位置を基準として設定(列見出しの最左セル位置)
  Set rngResult = Worksheets("一覧").Cells(1, "A")
  
  With rngList
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'データが無い場合
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データListを"氏名"順の"課題番号"順の"項目"順の"作業日付"順で整列
    .Offset(1).Resize(lngRows, clngColumns).Sort _
        Key1:=.Offset(, 4), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    .Offset(1).Resize(lngRows, clngColumns).Sort _
        Key1:=.Offset, Order1:=xlAscending, _
        Key2:=.Offset(, 1), Order2:=xlAscending, _
        Key3:=.Offset(, 3), Order3:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '作業日付のMax、Minを取得
    With .Offset(1, clngColumns - 2).Resize(lngRows)
      vntDayMax = Application.WorksheetFunction.Max(.Resize(lngRows))
      vntDayMin = Application.WorksheetFunction.Min(.Resize(lngRows))
    End With
  End With
  '日付先頭日を計算
  vntDayMin = CLng(DateSerial(Year(vntDayMin), Month(vntDayMin), 1))
  '日数を計算
  vntDayMax = CLng(DateSerial(Year(vntDayMax), Month(vntDayMax) + 1, 0)) _
            - vntDayMin + 1
  '結果配列を確保
  ReDim vntResult(1 To 1, 1 To vntDayMax + clngDayTop - 1)
  '先頭項目を代入
  For i = 1 To clngDayTop - 1
    vntResult(1, i) = Choose(i, "氏名", "課題番号", "件名", "項目")
  Next i
  '日付を代入
  For i = 0 To vntDayMax - 1
    vntResult(1, clngDayTop + i) = vntDayMin + i
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '一覧シートの初期化
  With rngResult
    'シートをクリア
    .Parent.Cells.ClearContents
    '日付のセル範囲の書式設定
    .Offset(, clngDayTop - 1).Resize(, _
          vntDayMax).NumberFormatLocal = "d""日"""
    '項目、日付を出力
    .Resize(, UBound(vntResult, 2)).Value = vntResult
  End With
  
  '結果配列を再確保
  ReDim vntResult(1 To 1, 1 To vntDayMax + clngDayTop - 1)
  'データシートから先頭1行を配列に取得
  vntData = rngList.Offset(1).Resize(, clngColumns).Value
  '各項目を結果配列に転記
  For i = 1 To clngDayTop - 1
    vntResult(1, i) = vntData(1, i)
  Next i
  '作業時間を作業日付位置に代入
  vntResult(1, vntData(1, clngDayTop) - vntDayMin + clngDayTop) _
      = vntData(1, clngDayTop + 1)
  ReDim Preserve vntData(1 To 1, 1 To clngDayTop - 1)
  '比較項目を作成
  vntComp = vntData
  
  '2行目から最終行まで繰り返し
  For i = 2 To lngRows + 1
    'データ1行を配列に取得
    vntData = rngList.Offset(i).Resize(, clngColumns).Value
    'もし、"氏名"、 "課題番号"、 "件名"、 "項目"の1つでも違った場合
    If Not DataCheck(vntData, vntComp) Then
      '出力行を更新
      lngRow = lngRow + 1
      '結果配列を出力
      rngResult.Offset(lngRow).Resize(, _
          UBound(vntResult, 2)).Value = vntResult
      '出力用配列を初期化
      IinitializeArray vntData, vntResult, vntComp
    End If
    '作業時間を作業日付位置に代入
    If vntData(1, 1) <> "" Then
      vntResult(1, vntData(1, clngDayTop) - vntDayMin + clngDayTop) _
          = vntData(1, clngDayTop + 1)
    End If
  Next i
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function DataCheck(vntData As Variant, _
              vntComp As Variant) As Boolean

'  "氏名", "課題番号", "件名", "項目"が前と変わった場合
'  Falseを返す

  Dim i As Long
  
  DataCheck = True
  
  For i = 1 To UBound(vntComp, 2)
    If vntData(1, i) <> vntComp(1, i) Then
      DataCheck = False
      Exit Function
    End If
  Next i
  
End Function

Private Sub IinitializeArray(vntData As Variant, _
              vntResult As Variant, _
              vntComp As Variant)

'  結果出力用配列と比較用配列の初期化

  Dim i As Long
  
  For i = UBound(vntComp, 2) + 1 To UBound(vntResult, 2)
    vntResult(1, i) = Empty
  Next i
  
  For i = 1 To UBound(vntComp, 2)
    If vntData(1, i) = vntComp(1, i) Then
      vntResult(1, i) = Empty
    Else
      vntResult(1, i) = vntData(1, i)
      vntComp(1, i) = vntData(1, i)
    End If
  Next i
  
End Sub
0 hits

【33033】データの入れ替え 小太郎 05/12/29(木) 15:32 質問
【33034】Re:データの入れ替え やっちん 05/12/29(木) 15:52 発言
【33049】Re:データの入れ替え Hirofumi 05/12/30(金) 16:57 回答

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