Excel VBA質問箱 IV

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

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


53176 / 76732 ←次へ | 前へ→

【28375】Re:外部ファイルの自動読み込みについて
回答  Hirofumi  - 05/9/4(日) 13:30 -

引用なし
パスワード
   一応、Upされたレイアウトとデータに因り、
「Public Sub CrossTabulation」のTestをして見た結果の修正変更をUpします

1、「Public Sub CrossTabulation()」に就いては、
 変更箇所が多いのでこのプロシージャ全文を載せます

Public Sub CrossTabulation()

  '日付の先頭位置の前の列
  Const clngTop As Long = 11
  'ファイル名Listの有るシート名
  Const cstrList As String = "FileList"

  Dim i As Long
  Dim strPath As String
  Dim vntFileNames As Variant
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim lngCol As Long
  Dim lngRow As Long
  Dim rngScope As Range
  Dim rngResult As Range
  Dim rngDate As Range
  Dim wksFiles As Worksheet

  'ファイル名Listの有るシートの確認
  FileListCheck cstrList, wksFiles

  'Textファイルの有るフォルダを指定
  strPath = "C:\system"

  '読み込むファイルを取得(ダイアログを出さないで、指定フォルダから取得の場合)
  If Not GetAppendFile(vntFileNames, strPath, "txt", _
      "^[0-9][0-9][0-9][0-9][0-9][0-9]da*$|^[0-9][0-9][0-9][0-9][0-9][0-9]da~[0-9]*$", _
            wksFiles) Then  'もっと上手い書き方が有る様な?
    GoTo Wayout
  End If

  Application.ScreenUpdating = False

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(7, "A")
  With rngResult
    '日付の書かれている列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column _
            - .Offset(, clngTop).Column
    '日付列の範囲を取得
    If lngCol > 0 Then
      Set rngDate = .Offset(, clngTop + 1).Resize(, lngCol)
    End If
    'No.が有る行数を取得
    lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'No.が有る範囲を取得
    If lngRow > 0 Then
      Set rngScope = .Offset(1).Resize(lngRow)
    End If
  End With

  For i = 1 To UBound(vntFileNames)
    '指定されたファイルをOpen
    dfn = FreeFile
    Open vntFileNames(i) For Input As dfn
    'ファイルから日付を取得
    Do Until EOF(dfn)
      'ファイルから1行読み込み
      Line Input #dfn, strBuff
      'フィールドに分割
      vntField = Split(strBuff, ",", , vbBinaryCompare)
      '「20050731」形式の日付をシリアル値に変換
      vntField(0) = CLng(DateValue(Left(vntField(0), 4) _
                & "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2)))
      '日付を探索
      lngCol = GetDateColumn(vntField(0), rngDate, _
                rngResult.Offset(, clngTop)) + clngTop
      'No.を探索
      lngRow = GetTagNoRow(vntField(5), rngScope, rngResult)
      '日付、Noの交差するセルに値を書き込み
      With rngResult.Offset(lngRow, lngCol)
        .NumberFormatLocal = "G/標準"
        .Value = vntField(6)
      End With
    Loop
    Close #dfn
  Next i

Wayout:

  Application.ScreenUpdating = True

  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing
  Set wksFiles = Nothing

  Beep

End Sub

尚、日付は、追加する形に成る為、Log出力はしません

2、「Private Function GetTagNoRow」は、以下を追加

    With rngListTop
      '行末位置を更新
      lngCount = lngCount + 1
      'セルの書式を文字列に設定
      '(001の様な場合無いと探索が出来ない)
      .Offset(lngCount).NumberFormatLocal = "@" '★追加行
      '行末にNoを書き込み

 尚、Noを昇順に並べて行く様にするなら、プロシージャを以下の物と差し替えて下さい

Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Long
  Dim lngOver As Long
  Dim lngCount As Long

  '商品名範囲に商品名が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
    lngOver = 1
  Else
    '商品名を探索
    lngFound = DataSearch(vntTagNo, rngScope, lngOver)
    lngCount = rngScope.Rows.Count
  End If

  '探索成功(商品名が有るなら)
  If lngFound > 0 Then
    '位置を返す
    GetTagNoRow = lngFound
  Else
    With rngListTop
      '挿入位置が行末で無いなら
      If lngOver <= lngCount Then
        '行を挿入
        .Offset(lngOver).EntireRow.Insert
      End If
      'セルの書式を文字列に設定
      .Offset(lngOver).NumberFormatLocal = "@" '★追加行
      '商品名を書き込み
      .Offset(lngOver).Value = vntTagNo
      '挿入位置を返す
      GetTagNoRow = lngOver
      '探索範囲の更新
      Set rngScope _
        = .Offset(1).Resize(lngCount + 1)
    End With
  End If

End Function

3、「Private Function GetAppendFile」は不都合が有る為、
 以下の部分を3行追加、1行削除して下さい

  With rngList
    If lngRows > 0 Then
      .Resize(lngRows, 2).ClearContents
'      .Resize(j, 2).Value = vntData '☆削除行
    End If
    If j > 0 Then '◎追加行
      .Resize(j, 2).Value = vntData '◎追加行
    End If '◎追加行
    If VarType(vntFileNames) = vbArray + vbVariant Then
      .Offset(j).Resize(UBound(vntFileNames)).Value _
          = Application.Transpose(vntFileNames)
    End If
  End With

Wayout:

4、テストする時は、必ず「Public Sub CrossTabulation()」の方を先にして下さい
 タイマー関連は、後回しにする
 また、一度動かすと、マクロの有るBookに「FileList」と言うシートができ
 其処に、読み込んだファイル名が書き込まれます
 ここに、表示されているファイルは、次回は読み込まれないので、
 テストの時は、このファイル名を削除して下さい

5、
>Private Sub Workbook_Open() について
>間違いに気がつきました。
>
>パソコンを起動、或いはBOOKを開いたときに
>シート1に対しマクロをを実行させたいのですが
>どのようにするのが良いでしょうか

「パソコンを起動」した時はどうしようも有りませんが?
(実際は、タスクスケジュラー等でやれる様なきもしますが?)
「BOOKを開いたとき」は、ThisWorkBookのコードモジュールに

Option Explicit

Private Sub Workbook_Open()

  CrossTabulation
  
End Sub

とすれば実行出きると思います

0 hits

【28362】外部ファイルの自動読み込みについて ミツコ 05/9/3(土) 17:46 質問
【28367】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 2:15 回答
【28368】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 2:17 回答
【28370】Re:外部ファイルの自動読み込みについて ミツコ 05/9/4(日) 9:13 質問
【28371】Re:外部ファイルの自動読み込みについて ミツコ 05/9/4(日) 9:14 質問
【28372】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 10:36 回答
【28373】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 11:18 発言
【28374】Re:外部ファイルの自動読み込みについて ミツコ 05/9/4(日) 11:31 質問
【28375】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 13:30 回答
【28376】Re:外部ファイルの自動読み込みについて ミツコ 05/9/4(日) 17:50 質問
【28377】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 19:12 回答
【28378】Re:外部ファイルの自動読み込みについて ミツコ 05/9/4(日) 20:06 質問
【28379】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/4(日) 21:11 回答
【28751】Re:外部ファイルの自動読み込みについて ミツコ 05/9/13(火) 22:42 質問
【28796】Re:外部ファイルの自動読み込みについて Hirofumi 05/9/14(水) 21:35 回答
【28753】Re:外部ファイルの自動読み込みについて ミツコ 05/9/13(火) 22:48 質問
【32249】Hirofumiさん教えてください。 ミツコ 05/12/11(日) 11:15 質問
【32250】現在利用しているコードも記載します1. ミツコ 05/12/11(日) 11:27 質問
【32251】現在利用しているコードも記載します2. ミツコ 05/12/11(日) 11:28 質問
【32252】Re:現在利用しているコードも記載します2. Hirofumi 05/12/11(日) 13:00 回答
【32273】Re:現在利用しているコードも記載します2. ミツコ 05/12/12(月) 1:56 お礼

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