Excel VBA質問箱 IV

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

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


10522 / 13644 ツリー ←次へ | 前へ→

【21264】表へのデータ挿入について kitty 05/1/17(月) 23:53 質問[未読]
【21265】Re:表へのデータ挿入について IROC 05/1/18(火) 8:44 回答[未読]
【21271】Re:表へのデータ挿入について kitty 05/1/18(火) 10:36 質問[未読]
【21273】Re:表へのデータ挿入について IROC 05/1/18(火) 10:52 回答[未読]
【21278】Re:表へのデータ挿入について kitty 05/1/18(火) 12:24 質問[未読]
【21279】Re:表へのデータ挿入について IROC 05/1/18(火) 12:56 回答[未読]
【21299】Re:表へのデータ挿入について kitty 05/1/18(火) 16:16 質問[未読]
【21300】Re:表へのデータ挿入について IROC 05/1/18(火) 16:39 回答[未読]
【21325】Re:表へのデータ挿入について kitty 05/1/18(火) 19:42 発言[未読]
【21330】Re:表へのデータ挿入について IROC 05/1/18(火) 20:54 回答[未読]
【21327】Re:表へのデータ挿入について Hirofumi 05/1/18(火) 20:27 回答[未読]
【21331】Re:表へのデータ挿入について Hirofumi 05/1/18(火) 21:53 発言[未読]
【21335】Re:表へのデータ挿入について kitty 05/1/19(水) 0:06 お礼[未読]

【21264】表へのデータ挿入について
質問  kitty  - 05/1/17(月) 23:53 -

引用なし
パスワード
   アドバイスよろしくお願いします。

下のテキストデータをエクセルの表に取り込もうと思います。
並びは日付,時間,秒,0,0,ID,コード,値 です。

20050102,1000,0,0,102,00100010,111
20050102,1000,0,0,106,00100020,112
20050102,1000,0,0,104,00100030,113
20050102,1000,0,0,105,00100040,114
20050102,1000,0,0,101,00100050,11
20050102,1000,0,0,108,00100120,122
20050102,1000,0,0,101,00100130,123
20050102,1000,0,0,103,00100140,124
20050102,1000,0,0,101,00100150,125
以下500行程続く


エクセルの表は↓になります。Cセルに上記データの値を入力

セル A     B   C
5  登録    巡回   値
6  コード   名称  20050102
7  00100010  A  
8  00100020  B  
9  00100030  C  
10  00100040  D  
11  00100050  E  
12  00100120  F  
13  00100130  G


過去の質問を参考に下記マクロを試しました。
---------------------------------------------------
Option Explicit

Public Sub メーター()

  Dim vntFileName 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 blnWayOut As Boolean
 
  '「ファイルを開く」ダイアログを表示
  If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
    Exit Sub
  End If
 
  Application.ScreenUpdating = False
 
  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(6, "A")
  With rngResult
    '日付の書かれている列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column
    '日付の有る範囲を取得
     If lngCol = 0 Then
      blnWayOut = True
      GoTo WayOut
    End If
    '日付列の範囲を取得
    Set rngDate = .Offset(, 1).Resize(, lngCol)
    'タグNo.が有る範囲を取得
    Set rngScope = Range(.Offset(1), .Offset(65536 - .Row).End(xlUp))
  End With
 
  '指定されたファイルをOpen
  dfn = FreeFile
  Open vntFileName For Input As dfn

  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    '日付を探索
    lngCol = GetDateColumn(vntField(0), rngDate, rngResult)
    'タグNo.を探索
    lngRow = GetTagNoRow(vntField(5), rngScope, rngResult)
    '日付、TagNoの交差するセルに値を書き込み
    rngResult.Offset(lngRow, lngCol).Value = vntField(6)
  Loop
 
  Close #dfn
 
WayOut:
 
  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing
 
  Application.ScreenUpdating = True

  Beep
If blnWayOut Then
    MsgBox "該当する日付の列が有りません"
  Else
    MsgBox "処理が完了しました"
  End If

  
End Sub

Private Function GetDateColumn(vntDate As Variant, _
                rngScope As Range, _
                rngListTop As Range) As Long
 
  Dim lngFound As Long
  Dim lngOver As Long
 
  'セル値が数値として入力されている場合
  lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
  'セル値が文字列として入力されている場合
'  lngFound = DataSearch(vntDate, rngScope, lngOver)
  '日付が見つかった場合
  If lngFound > 0 Then
    '位置を返す
    GetDateColumn = lngFound
  Else
    With rngListTop
      '日付が最終列の以内の場合
      If lngOver <= rngScope.Columns.Count Then
        '指定位置に列を挿入
        .Offset(, lngOver).EntireColumn.Insert
      End If
      '日付を書き込み
      .Offset(, lngOver).Value = vntDate
      '挿入位置を返す
      GetDateColumn = lngOver
      '日付列の範囲を更新
      Set rngScope _
        = .Offset(, 1).Resize(, rngScope.Columns.Count + 1)
    End With
  End If
   
End Function

Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long
 
  Dim lngFound As Long
  Dim lngOver As Long
 
  lngFound = DataSearch(vntTagNo, rngScope, lngOver)
  If lngFound > 0 Then
    GetTagNoRow = lngFound + 1
  Else
    With rngListTop.Offset(1)
      If lngOver <= rngScope.Rows.Count Then
        .Offset(lngOver).EntireRow.Insert
      End If
      .Offset(lngOver).Value = vntTagNo
      GetTagNoRow = lngOver + 1
      Set rngScope _
        = .Offset(1).Resize(rngScope.Rows.Count + 1)
    End With
  End If

End Function

Private Function DataSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long) As Long

  Dim vntFind As Variant
 
  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, 1)
  lngOver = 1
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind).Value Then
      '戻り値として、行位置を代入
      DataSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  End If
 
End Function

Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean = False) As Boolean

  Dim strFilter As String
 
  'フィルタ文字列を作成
  strFilter = "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "Text File (*.txt),*.txt," _
        & "CSV File (*.csv),*.csv," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames & "{TAB}", False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
 
  GetReadFile = True
 
End Function

---------------------------------------------------


しかし下記のように日付直下に値が入らず、一段づつ下へズレて入力されます。
何が悪いのでしょうか?

セル A     B   C
5  登録    巡回   値
6  コード   名称  20050102
7  00100010  A  
8  00100020  B    111
9  00100030  C    112
10  00100040  D    113
11  00100050  E    114
12  00100120  F    11
13  00100130  G    122
14  00100140  H    123
             124

【21265】Re:表へのデータ挿入について
回答  IROC  - 05/1/18(火) 8:44 -

引用なし
パスワード
   ステップ実行とローカルウィンドウを使ってデバッグしてみましたか?

【21271】Re:表へのデータ挿入について
質問  kitty  - 05/1/18(火) 10:36 -

引用なし
パスワード
   原因が判りました。下記に問題が有りました。
GetTagNoRow = lngFound + 1


また別件ですが
現在「ファイルを開く」(ダイアログを表示)よりテキストデータを選択し挿入しています。

毎回下記に保存されているデータを指定して自動入力するにはどのようにすれば良いでしょうか?
C:\Documents and Settings\aep\デスクトップ\管理\jyunkai.txt

【21273】Re:表へのデータ挿入について
回答  IROC  - 05/1/18(火) 10:52 -

引用なし
パスワード
   これで良いでしょうか?


Dim fileToOpen As Variant

ChDrive "C"
ChDir "C:\Documents and Settings\aep\デスクトップ\管理\"
SendKeys "jyunkai.txt"
fileToOpen = Application.GetOpenFilename("テキスト ファイル (*.txt), *.txt")

  If fileToOpen <> False Then
    MsgBox "選択されたファイル : " & fileToOpen
  End If

【21278】Re:表へのデータ挿入について
質問  kitty  - 05/1/18(火) 12:24 -

引用なし
パスワード
   IROC さん

ありがとうございます。
動作は上手くできました。しかしダイアログのファイル名が"jyunkai.txt"ではなく"じゅんかい.txt"と表示されるのが不思議に思いました。


また今回、試行錯誤していますのは少し違いまして
ダイアログを開かずに特定ファイルを開く方法に苦戦しています。
どうかアドバイスをお願いします。
C:\Documents and Settings\aep\デスクトップ\管理\jyunkai.txt

【21279】Re:表へのデータ挿入について
回答  IROC  - 05/1/18(火) 12:56 -

引用なし
パスワード
   >動作は上手くできました。しかしダイアログのファイル名が"jyunkai.txt"ではなく"
>じゅんかい.txt"と表示されるのが不思議に思いました。

sendkeys はキー操作を送信する構文です。
日本語入力がONの状態のときは、そのようになってしまいます。
日本語入力がOFFになっていれば問題ないはずです。

日本語入力をOFFにするには、どこかのセルに入力規則を設定し、
マクロ実行前にそのセルをSelectしておいて下さい。

【21299】Re:表へのデータ挿入について
質問  kitty  - 05/1/18(火) 16:16 -

引用なし
パスワード
   ▼IROC さん:
ありがとうございました。

>日本語入力がONの状態のときは、そのようになってしまいます。
>日本語入力がOFFになっていれば問題ないはずです。
これは残念です。


何方か
ダイアログを開かずに特定ファイルを読み込む方法をどうかアドバイスをお願いします。

C:\Documents and Settings\aep\デスクトップ\管理\jyunkai.txt

【21300】Re:表へのデータ挿入について
回答  IROC  - 05/1/18(火) 16:39 -

引用なし
パスワード
   「ファイルを開く」か「テキストファイルのインポート」をマクロの記録しては?

【21325】Re:表へのデータ挿入について
発言  kitty  - 05/1/18(火) 19:42 -

引用なし
パスワード
   ▼IROC さん:
ありがとうございます。

>「ファイルを開く」か「テキストファイルのインポート」をマクロの記録しては?
これでは読込み処理が出来ないと思います。

【21327】Re:表へのデータ挿入について
回答  Hirofumi  - 05/1/18(火) 20:27 -

引用なし
パスワード
   このコードで「ファイルを開く」ダイアログを表示しているのは、
「Sub メーター()」の中の以下の部分です
因って以下の4行を削除

  '「ファイルを開く」ダイアログを表示
  If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
    Exit Sub
  End If

上記の替わりに以下を追加

  vntFileName = "C:\Documents and Settings\aep\デスクトップ\管理\jyunkai.txt"

で善いでしょう

【21330】Re:表へのデータ挿入について
回答  IROC  - 05/1/18(火) 20:54 -

引用なし
パスワード
   >これでは読込み処理が出来ないと思います。
何故ですか?

【21331】Re:表へのデータ挿入について
発言  Hirofumi  - 05/1/18(火) 21:53 -

引用なし
パスワード
   >しかし下記のように日付直下に値が入らず、一段づつ下へズレて入力されます。
>何が悪いのでしょうか?

後、上記に就いてですが?
今回、修正されたコードでは、

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(6, "A")

と成っていますし、其れに伴って、

    'タグNo.が有る範囲を取得
    Set rngScope = Range(.Offset(1), .Offset(65536 - .Row).End(xlUp))

で、.Offset(1)を指定していますが、元々のコードでは、
A5の「登録」の位置を指定しているはずですし、.Offsetも以下の様に2を指定してたはずです

    'タグNo.が有る範囲を取得
    Set rngScope = Range(.Offset(2), .Offset(65536 - .Row).End(xlUp))

此れにより、行位置が狂ってきている為と思われます
完全に、今回のコードを見て居ないのでハッキリしませんが、
若しかすると、此れにより日付の挿入位置を狂ってきているのでは?

【21335】Re:表へのデータ挿入について
お礼  kitty  - 05/1/19(水) 0:06 -

引用なし
パスワード
   ▼Hirofumi さん:
ありがとうございました。

1日かかりましたが何とか解決しました。


>>しかし下記のように日付直下に値が入らず、一段づつ下へズレて入力されます。
>>何が悪いのでしょうか?
>
>後、上記に就いてですが?
>今回、修正されたコードでは、
>
>  'ActiveSheetのA1セルを基準とする(Listの左上隅)
>  Set rngResult = ActiveSheet.Cells(6, "A")
>
>と成っていますし、其れに伴って、
>
>    'タグNo.が有る範囲を取得
>    Set rngScope = Range(.Offset(1), .Offset(65536 - .Row).End(xlUp))
>
>で、.Offset(1)を指定していますが、元々のコードでは、
>A5の「登録」の位置を指定しているはずですし、.Offsetも以下の様に2を指定してたはずです
>
>    'タグNo.が有る範囲を取得
>    Set rngScope = Range(.Offset(2), .Offset(65536 - .Row).End(xlUp))
>
>此れにより、行位置が狂ってきている為と思われます
>完全に、今回のコードを見て居ないのでハッキリしませんが、
>若しかすると、此れにより日付の挿入位置を狂ってきているのでは?

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