Excel VBA質問箱 IV

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

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


10627 / 13646 ツリー ←次へ | 前へ→

【20503】表へのCSVデータ挿入について ディノ 04/12/10(金) 15:31 質問[未読]
【20518】Re:表へのCSVデータ挿入について [名前なし] 04/12/10(金) 22:35 発言[未読]
【20519】Re:表へのCSVデータ挿入について ディノ 04/12/10(金) 22:54 質問[未読]
【20520】Re:表へのCSVデータ挿入について [名前なし] 04/12/10(金) 23:13 回答[未読]
【20521】Re:表へのCSVデータ挿入について ディノ 04/12/11(土) 0:39 質問[未読]
【20522】Re:表へのCSVデータ挿入について [名前なし] 04/12/11(土) 0:48 回答[未読]
【20523】Re:表へのCSVデータ挿入について [名前なし] 04/12/11(土) 1:24 発言[未読]
【20537】Re:表へのCSVデータ挿入について Hirofumi 04/12/11(土) 18:47 回答[未読]
【20603】Re:表へのCSVデータ挿入について Jaka 04/12/13(月) 10:51 回答[未読]
【20614】Re:表へのCSVデータ挿入について ディノ 04/12/13(月) 15:10 質問[未読]
【20640】Re:表へのCSVデータ挿入について Hirofumi 04/12/13(月) 19:46 回答[未読]
【20651】Re:表へのCSVデータ挿入について ディノ 04/12/14(火) 1:22 質問[未読]
【20675】Re:表へのCSVデータ挿入について Hirofumi 04/12/14(火) 19:33 回答[未読]
【20682】Re:表へのCSVデータ挿入について ディノ 04/12/15(水) 0:37 発言[未読]
【20699】Re:表へのCSVデータ挿入について Hirofumi 04/12/15(水) 21:17 回答[未読]
【20728】Re:表へのCSVデータ挿入について ディノ 04/12/16(木) 19:16 質問[未読]
【20730】Re:表へのCSVデータ挿入について Hirofumi 04/12/16(木) 20:14 回答[未読]
【20731】Re:表へのCSVデータ挿入について Hirofumi 04/12/16(木) 20:18 回答[未読]
【20735】Re:表へのCSVデータ挿入について ディノ 04/12/16(木) 22:05 質問[未読]
【20757】Re:表へのCSVデータ挿入について Hirofumi 04/12/17(金) 19:39 回答[未読]
【20759】Re:表へのCSVデータ挿入について ディノ 04/12/17(金) 20:53 質問[未読]
【20761】Re:表へのCSVデータ挿入について Hirofumi 04/12/17(金) 22:19 回答[未読]
【20763】Re:表へのCSVデータ挿入について Hirofumi 04/12/17(金) 23:04 回答[未読]
【20767】Re:表へのCSVデータ挿入について ディノ 04/12/18(土) 0:15 お礼[未読]

【20503】表へのCSVデータ挿入について
質問  ディノ  - 04/12/10(金) 15:31 -

引用なし
パスワード
   メーターの管理をバーコード認証で行っています。
下記のデータがCSVとして毎日出力されます。
 日付  時間 秒 タグNo 値
20041201,1401,51,Y1-H-102,102
20041201,1404,08,D1-H-105,105
20041201,1413,23,H1-F-114,114
20041201,1407,34,V1-P-108,108
20041201,1412,11,Y1-P-113,113
 ・
 ・
 ・

これを下記のように予めある表の中に値だけ挿入していきたく思います。
マクロで可能でしょうか?
可能な場合、どのような関数になるでしょうか?
現在、クロス集計を利用しCSVデータを整理していますが、この場合タグNoの
配列を任意に設定できないため困っています。
よろしくお願いします。

日付20041201
タグNo  値
Y1-H-101
Y1-H-102
Y1-H-103
Y1-P-101
 ・
 ・
Y1-P-113
 ・
 ・
続く

【20518】Re:表へのCSVデータ挿入について
発言  [名前なし]  - 04/12/10(金) 22:35 -

引用なし
パスワード
   ところで、どの処理が出来ないのでしょうか。

【20519】Re:表へのCSVデータ挿入について
質問  ディノ  - 04/12/10(金) 22:54 -

引用なし
パスワード
   例えばCSVデータで下記を例にとるとします。
20041201,1401,51,Y1-H-102,102

予め以下の表が存在するためRangeやCellsなどセルを直接指定するのでなく
X軸:日付、Y軸:タグNoでCSVから値を検索し入力、或いはY1-H-102の隣のセルに値を入れる、というマクロはできないものでしょうか?

   日付20041201
タグNo  値
Y1-H-101
Y1-H-102 102
Y1-H-103
Y1-P-101

【20520】Re:表へのCSVデータ挿入について
回答  [名前なし]  - 04/12/10(金) 23:13 -

引用なし
パスワード
   こういうことでしょうか。
Sub Macro1()
  Dim InputRecord As String
  Dim strDate As String, strTagNo As String, strValue As String
  Dim TempArray
  Dim X As Long, Y As Long
  InputRecord = "20041201,1401,51,Y1-H-102,102"
  TempArray = Split(InputRecord, ",")
  strDate = TempArray(0): strTagNo = TempArray(3): strValue = TempArray(4)
  X = Rows("1:1").Find(strDate).Column
  Y = Columns("A:A").Find(strTagNo).Row
  Cells(Y, X).Value = strValue
End Sub

1行目が日付、1列目がタグNoと仮定しています。

【20521】Re:表へのCSVデータ挿入について
質問  ディノ  - 04/12/11(土) 0:39 -

引用なし
パスワード
   マクロまで組んで頂きとても感謝します。

はい。
入力のイメージは下記マクロのようになります。
CSVからの読込み利用は可能でしょうか

>こういうことでしょうか。
>Sub Macro1()
>  Dim InputRecord As String
>  Dim strDate As String, strTagNo As String, strValue As String
>  Dim TempArray
>  Dim X As Long, Y As Long
>  InputRecord = "20041201,1401,51,Y1-H-102,102"
>  TempArray = Split(InputRecord, ",")
>  strDate = TempArray(0): strTagNo = TempArray(3): strValue = TempArray(4)
>  X = Rows("1:1").Find(strDate).Column
>  Y = Columns("A:A").Find(strTagNo).Row
>  Cells(Y, X).Value = strValue
>End Sub
>
>1行目が日付、1列目がタグNoと仮定しています。

【20522】Re:表へのCSVデータ挿入について
回答  [名前なし]  - 04/12/11(土) 0:48 -

引用なし
パスワード
   ▼ディノ さん:
>マクロまで組んで頂きとても感謝します。
>
>はい。
>入力のイメージは下記マクロのようになります。
>CSVからの読込み利用は可能でしょうか

こちらからお好きなのをどうぞ。
http://www.vbalab.net/vbaqa/c-board.cgi?word=CSV+%83e%83L%83X%83g+%93%C7%82%DD%8D%9E%82%DD&way=0&target=all&view=0&id=excel&cmd=src&x=33&y=6

【20523】Re:表へのCSVデータ挿入について
発言  [名前なし]  - 04/12/11(土) 1:24 -

引用なし
パスワード
   補足ですが、検索キーワードを変えると結構出てきます。
「テキストファイルから」とか。

【20537】Re:表へのCSVデータ挿入について
回答  Hirofumi  - 04/12/11(土) 18:47 -

引用なし
パスワード
   何か余り上手いコードじゃないけれど?
こんなかな?
上手く行かなかったらゴメン
条件としては、
タグNo.は、既に書き込んで有って昇順としてソートされています
日付も、既に書き込んで有る物とします
書き込む表をActiveSheetとして、マクロを実行して下さい
書き込む表のレイアウトは、以下の様に成ります

  A     B
1 日付    20041201
2 タグNo   値
3 Y1-H-101
4 Y1-H-102
5 Y1-H-103
6 Y1-P-101
7  ・
8  ・
9 Y1-P-113

Option Explicit

Public Sub PutData()

  Dim vntFileName As Variant
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim lngCol As Long
  Dim rngScope As Range
  Dim strNoMatch As String
  
  '「ファイルを開く」ダイアログを表示
  If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
    Exit Sub
  End If
  
'  Application.ScreenUpdating = False
  
  '指定されたファイルをOpen
  dfn = FreeFile
  Open vntFileName For Input As dfn

  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    '先頭フィールが日付と認められるならLoopを抜ける
    If IsDate(Left(vntField(0), 4) _
          & "/" & Mid(vntField(0), 5, 2) _
              & "/" & Right(vntField(0), 2)) Then
      Exit Do
    End If
  Loop
  
  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  With ActiveSheet.Cells(1, "A")
    '日付の書かれている列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column
    '日付の書かれている列があるなら
    If lngCol > 0 Then
      'ファイルの日付と同じ日付が有るか探索
      'セル値が数値として入力されている場合
      lngCol = DataSearch(CLng(vntField(0)), _
                .Offset(, 1).Resize(, lngCol))
      'セル値が文字列として入力されている場合
'      lngCol = DataSearch(vntField(0), _
                .Offset(, 1).Resize(, lngCol))
    End If
    'タグNo.が有る範囲を取得
    Set rngScope = Range(.Offset(2), .Offset(65536 - .Row).End(xlUp))
  End With
  'もし、日付列が無い場合終了
  If lngCol = 0 Then
    GoTo WayOut
  End If
  
  '先頭行のタグNo.を探索、書きこみ
  DataWrite rngScope, vntField, lngCol, strNoMatch
  
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    'タグNo.を探索、書きこみ
    DataWrite rngScope, vntField, lngCol, strNoMatch
  Loop
  
  If strNoMatch <> "" Then
    Beep
    MsgBox "以下のタグNo.が表に有りません" & vbCrLf & strNoMatch
  End If
  
WayOut:
  
  Close #dfn
  Set rngScope = Nothing
  
'  Application.ScreenUpdating = True

  Beep
  If lngCol = 0 Then
    MsgBox "該当する日付の列見出しが有りません"
  Else
    MsgBox "処理が完了しました"
  End If
    
End Sub

Private Sub DataWrite(rngWrite As Range, _
            vntKey As Variant, _
            lngCol As Long, _
            strNoMatch As String)
  
  Dim lngFound As Long
  
  lngFound = DataSearch(vntKey(3), rngWrite)
  If lngFound > 0 Then
    rngWrite(lngFound).Offset(, lngCol).Value = vntKey(4)
  Else
    If strNoMatch <> "" Then
      strNoMatch = strNoMatch & vbCrLf
    End If
    strNoMatch = strNoMatch & vntKey(3)
  End If

End Sub

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 File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt," _
        & "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  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

【20603】Re:表へのCSVデータ挿入について
回答  Jaka  - 04/12/13(月) 10:51 -

引用なし
パスワード
   こんにちは。
詳細が良く解らない上、ソートとか全く考えてません。
書いてきたので、一応載っけてみます。
尚、初回の質問文以降見てませんから、全くでたらめかも。

データCSV名を「メーターの管理.csv」として、かつ開いている状態で。
B3に下記関数を入れ下にフィルドラッグ。
(注)半角英数の文字が長いとUPできないので、適当な所で改行してあります。
=IF(ISNA(INDEX(メーターの管理.csv!$D$1:$E$5,MATCH(A3,メーターの管理.csv!$D$1:$D$5,0),1))
,"",INDEX(メーターの管理.csv!$D$1:$E$5,MATCH(A3,メーターの管理.csv!$D$1:$D$5,0),2))

これをマクロですると、

'データCSV名を「メーターの管理.csv」として、かつ開いている状態で。
Sub mmmet()
  データCSV名 = "メーターの管理.csv"
  With ThisWorkbook.Sheets(1)
     With .Range("A3", .Range("A65536").End(xlUp)).Offset(, 1)
       .Formula = "=IF(ISNA(INDEX(" & データCSV名 & "!$D$1:$E$5,MATCH(A3," & _
            データCSV名 & "!$D$1:$D$5,0),1)),"""",INDEX(" & データCSV名 & _
            "!$D$1:$E$5,MATCH(A3," & データCSV名 & "!$D$1:$D$5,0),2))"
       '.Value = .Value  '実数にしたい場合は、ここのチェックを外す。
     End With
  End With
End Sub

タグNoの下3桁が値と同じみたいなので、すべて同じパターンだったら下記で済みそうですけど。
=VALUE(RIGHT(A3,3))

【20614】Re:表へのCSVデータ挿入について
質問  ディノ  - 04/12/13(月) 15:10 -

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

Hirofumi さんのコード昨日から試していますけど
どうしても
"該当する日付の列見出しが有りません"
と出てきます。
原因がわかりません。

過去にも似たようなマクロが見当たらないため困っています。
どなたかアドバイス願います。

【20640】Re:表へのCSVデータ挿入について
回答  Hirofumi  - 04/12/13(月) 19:46 -

引用なし
パスワード
   >Hirofumi さんのコード昨日から試していますけど
>どうしても
>"該当する日付の列見出しが有りません"
>と出てきます。
>原因がわかりません。

条件としては、
タグNo.は、既に書き込んで有って昇順としてソートされています
日付も、既に書き込んで有る物とします
書き込む表をActiveSheetとして、マクロを実行して下さい
書き込む表のレイアウトは、以下の様に成ります

  A     B
1 日付    20041201
2 タグNo   値
3 Y1-H-101
4 Y1-H-102
5 Y1-H-103
6 Y1-P-101
7  ・
8  ・
9 Y1-P-113

この、メッセージが出る原因は、
1、表のレイアウトが、上記のように成っていますか?
 表の位置が同じどうか確認して下さい
2、上記の表の様に、B列以降の1行目に「20041201」の様に、
 読み込むファイルの1列目と同じ日付が、既に書き込まれていますか?
3、読み込むファイルの1列目と同じ日付が、既に書き込まれているのに出る場合
 セルがの書式設定が文字列に成っていて、書式設定後に「20041201」が書きこまれている
 詰まり、「20041201」が文字列の場合

等が考えられます

1で、レイアウトが同じで、表の位置が違っている場合

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  With ActiveSheet.Cells(1, "A")

の「.Cells(1, "A")」を、ディノさんの表の「日付」の文字列の有るセル位置に直して下さい

3で、「20041201」が文字列扱いの場合

      'セル値が数値として入力されている場合
'      lngCol = DataSearch(CLng(vntField(0)), _
                .Offset(, 1).Resize(, lngCol))
      'セル値が文字列として入力されている場合
      lngCol = DataSearch(vntField(0), _
                .Offset(, 1).Resize(, lngCol))

と成るように、上の行をコメントアウトして、
下の行のアポストロフィーを削除して、この行を活かして下さい

【20651】Re:表へのCSVデータ挿入について
質問  ディノ  - 04/12/14(火) 1:22 -

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

エラーの原因がわかりました。
CSVファイルにいつの間にか改行が入っていました。
悲しい。気が変になりそうです。


またCSVファイル内の日付が下記の様に複数でも対応できるようにしたいのですが、
20041201
20041201
20041201
20041202
20041202
20041202
20041204
イメージがつきません。ヒントを頂けないでしょうか

さらに、下記の「先頭フィールが日付と認められるならLoopを抜ける」
とは何を意味しているのでしょうか?良く理解ができませんでした。
ご指導お願いします。


  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    '先頭フィールが日付と認められるならLoopを抜ける
    If IsDate(Left(vntField(0), 4) _
          & "/" & Mid(vntField(0), 5, 2) _
              & "/" & Right(vntField(0), 2)) Then
      Exit Do
    End If
  Loop

【20675】Re:表へのCSVデータ挿入について
回答  Hirofumi  - 04/12/14(火) 19:33 -

引用なし
パスワード
   ▼>エラーの原因がわかりました。
>CSVファイルにいつの間にか改行が入っていました。
>悲しい。気が変になりそうです。
>
>
>またCSVファイル内の日付が下記の様に複数でも対応できるようにしたいのですが、
>20041201
>20041201
>20041201
>20041202
>20041202
>20041202
>20041204
>イメージがつきません。ヒントを頂けないでしょうか
>
>さらに、下記の「先頭フィールが日付と認められるならLoopを抜ける」
>とは何を意味しているのでしょうか?良く理解ができませんでした。
>ご指導お願いします。
>
>
>  'ファイルから日付を取得
>  Do Until EOF(dfn)
>    'ファイルから1行読み込み
>    Line Input #dfn, strBuff
>    'フィールドに分割
>    vntField = Split(strBuff, ",", , vbBinaryCompare)
>    '先頭フィールが日付と認められるならLoopを抜ける
>    If IsDate(Left(vntField(0), 4) _
>          & "/" & Mid(vntField(0), 5, 2) _
>              & "/" & Right(vntField(0), 2)) Then
>      Exit Do
>    End If
>  Loop

何処に、どの様に改行が入っているのですか?
データのサンプルをUpしてくれれば解決策が有るかも?
また最初の質問が、日々のデータと言う事でしたので
日付は全て同じと思い、日付は、1回だけしか見ていません
上記のコードは、最初に出てくる日付を1回だけ取得する目的と
先頭行が、データでは無くて、列見出しの場合の対策です
もし、データの日付が複数の場合、日付の列を行毎に探す事も出来ますし、
列の挿入を行っても善いなら、ファイルの日付毎に、日付を昇順に書きこんで
其処に、値を書き込む事も出来ます

【20682】Re:表へのCSVデータ挿入について
発言  ディノ  - 04/12/15(水) 0:37 -

引用なし
パスワード
   ▼Hirofumi さん

エラーの原因についてはマクロではなく
元のCSVデータにいつのまにか改行が入っていたためでした。
今は正常に動作しています。

またCSVデータに複数の日付が記録されることは
今後考えられるため、エラー防止の措置として考えています。
下記のように組んでみようと思います。

>列の挿入を行っても善いなら、ファイルの日付毎に、日付を昇順に書きこんで
>其処に、値を書き込む事も出来ます

【20699】Re:表へのCSVデータ挿入について
回答  Hirofumi  - 04/12/15(水) 21:17 -

引用なし
パスワード
   条件としては、
タグNo.は、既に1つ以上昇順に書き込んで有る事とします
もし、タグNo.が無い場合、昇順位置に行を挿入して書きこまれますが
既に書き込んで有った方が行挿入が行われませんので早く成ります
日付は、既に書き込んで無くてもファイルの値を書き込みます
ただし、タグNo.と同様既に書き込んで有った方が早く成ります
また、書き込む場合、左から右に昇順とします
日付、タグNoともに、昇順で書かれていない場合、結果は出鱈目に成ると思います
書き込む表をActiveSheetとして、マクロを実行して下さい
ファイルには、列見出しが無い物とします

Option Explicit

Public Sub PutData2()

  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(1, "A")
  With rngResult
    '日付の書かれている列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column
    '日付の有る範囲を取得
    If lngCol = 0 Then
      '指定されたファイルをOpen
      '日付の列が1つも無い場合後の処理が面倒なので
      '先にファイル先頭の日付を入れて置く
      dfn = FreeFile
      Open vntFileName For Input As dfn
      If Not EOF(dfn) Then
        'ファイルから1行読み込み
        Line Input #dfn, strBuff
        'フィールドに分割
        vntField = Split(strBuff, ",", , vbBinaryCompare)
      End If
      Close #dfn
      If VarType(vntField) = vbArray + vbVariant Then
        'ファイルから取得した日付書き込み
        .Offset(, 1).Value = vntField(0)
        lngCol = 1
      Else
        blnWayOut = True
        GoTo WayOut
      End If
    End If
    '日付列の範囲を取得
    Set rngDate = .Offset(, 1).Resize(, lngCol)
    'タグNo.が有る範囲を取得
    Set rngScope = Range(.Offset(2), .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(3), rngScope, rngResult)
    '日付、TagNoの交差するセルに値を書き込み
    rngResult.Offset(lngRow, lngCol).Value = vntField(4)
  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 File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt," _
        & "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  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

【20728】Re:表へのCSVデータ挿入について
質問  ディノ  - 04/12/16(木) 19:16 -

引用なし
パスワード
   ▼Hirofumi さん:

ありがとうございます。
一つ質問なのですが
日付がなくても自動的に書き込まれますが
初回のみ日付の入力が必要のようです。
日付が無いとエラーになるのですが
エラーが起きないように例えば
下記のようなマクロが必要と考えます。
どこで設定を追加すればよいでしょうか?

  If lngCol = 0 Then
    MsgBox "該当する日付の列見出しが有りません"
  Else


>条件としては、

>日付は、既に書き込んで無くてもファイルの値を書き込みます
>ただし、タグNo.と同様既に書き込んで有った方が早く成ります

【20730】Re:表へのCSVデータ挿入について
回答  Hirofumi  - 04/12/16(木) 20:14 -

引用なし
パスワード
   ▼ディノ さん:
>▼Hirofumi さん:
>
>ありがとうございます。
>一つ質問なのですが
>日付がなくても自動的に書き込まれますが
>初回のみ日付の入力が必要のようです。
>日付が無いとエラーになるのですが
>エラーが起きないように例えば
>下記のようなマクロが必要と考えます。
>どこで設定を追加すればよいでしょうか?
>
>  If lngCol = 0 Then
>    MsgBox "該当する日付の列見出しが有りません"
>  Else
>
>
>>条件としては、
>
>>日付は、既に書き込んで無くてもファイルの値を書き込みます
>>ただし、タグNo.と同様既に書き込んで有った方が早く成ります

変ですね、実行して見た結果ですか?
タグNo.の方は、手抜きしたので、1つ以上必ず書き込みが無いとエラー若しくは、
出鱈目に成ります
ただし、日付の方は何も無い場合、読み込み指定したファイルを1度Openし
1行だけ読み込んで、Closeして、日付だけ無条件で書き込んでいますので
エラーに成らないと思います
其れを、以下の部分で行っていますが?

    '日付の有る範囲を取得
    If lngCol = 0 Then
      '指定されたファイルをOpen
      '日付の列が1つも無い場合後の処理が面倒なので
      '先にファイル先頭の日付を入れて置く
      dfn = FreeFile
      Open vntFileName For Input As dfn
      If Not EOF(dfn) Then
        'ファイルから1行読み込み
        Line Input #dfn, strBuff
        'フィールドに分割
        vntField = Split(strBuff, ",", , vbBinaryCompare)
      End If
      Close #dfn
      If VarType(vntField) = vbArray + vbVariant Then
        'ファイルから取得した日付書き込み
        .Offset(, 1).Value = vntField(0)
        lngCol = 1
      Else
        blnWayOut = True
        GoTo WayOut
      End If
    End If

【20731】Re:表へのCSVデータ挿入について
回答  Hirofumi  - 04/12/16(木) 20:18 -

引用なし
パスワード
   後、此れも手抜きで申し訳有りませんが、
条件で
「ファイルには、列見出しが無い物とします」
の様に、ファイルの先頭行から、データで有る物としています
ファイルに、列見出しが有るのですか?

【20735】Re:表へのCSVデータ挿入について
質問  ディノ  - 04/12/16(木) 22:05 -

引用なし
パスワード
   ▼Hirofumi さん:
>後、此れも手抜きで申し訳有りませんが、
>条件で
>「ファイルには、列見出しが無い物とします」
>の様に、ファイルの先頭行から、データで有る物としています
>ファイルに、列見出しが有るのですか?


いいえ元ファイルに列見出しは無いです。
一つ教えて頂きたいのですが
If VarType(vntField) = vbArray + vbVariant Then
はどのような意味になるのでしょうか?


    '日付の有る範囲を取得
    If lngCol = 0 Then
      '指定されたファイルをOpen
      '日付の列が1つも無い場合後の処理が面倒なので
      '先にファイル先頭の日付を入れて置く
      dfn = FreeFile
      Open vntFileName For Input As dfn
      If Not EOF(dfn) Then
        'ファイルから1行読み込み
        Line Input #dfn, strBuff
        'フィールドに分割
        vntField = Split(strBuff, ",", , vbBinaryCompare)
      End If
      Close #dfn
      If VarType(vntField) = vbArray + vbVariant Then
        'ファイルから取得した日付書き込み
        .Offset(, 1).Value = vntField(0)
        lngCol = 1
      Else
        blnWayOut = True
        GoTo WayOut
      End If
    End If

【20757】Re:表へのCSVデータ挿入について
回答  Hirofumi  - 04/12/17(金) 19:39 -

引用なし
パスワード
   >いいえ元ファイルに列見出しは無いです。
>一つ教えて頂きたいのですが
>If VarType(vntField) = vbArray + vbVariant Then
>はどのような意味になるのでしょうか?
>
>
>    '日付の有る範囲を取得
>    If lngCol = 0 Then
>      '指定されたファイルをOpen
>      '日付の列が1つも無い場合後の処理が面倒なので
>      '先にファイル先頭の日付を入れて置く
>      dfn = FreeFile
>      Open vntFileName For Input As dfn
>      If Not EOF(dfn) Then
>        'ファイルから1行読み込み
>        Line Input #dfn, strBuff
>        'フィールドに分割
>        vntField = Split(strBuff, ",", , vbBinaryCompare)
>      End If
>      Close #dfn
>      If VarType(vntField) = vbArray + vbVariant Then
>        'ファイルから取得した日付書き込み
>        .Offset(, 1).Value = vntField(0)
>        lngCol = 1
>      Else
>        blnWayOut = True
>        GoTo WayOut
>      End If
>    End If

「If VarType(vntField) = vbArray + vbVariant Then」
此れは、vntFieldの変数が、Variant型の配列で有るか、否かを判定しています
もし、vntFileNameで読み込もうとしたファイルが、ファイル其の物は有るが
中身が無い場合(ファイルサイズが0)が有るので、其のエラー対策です

所で、コード自体は上手く動かないのですか?
其れが知りたいのですが?

【20759】Re:表へのCSVデータ挿入について
質問  ディノ  - 04/12/17(金) 20:53 -

引用なし
パスワード
   ▼Hirofumi さん:

ありがとうございます。
初回のみ日付を入れれば問題なく動作はします。
初回の日付が抜けていると下記エラーになるため
リセットをかけて再施行になります。

「アプリケーション定義またはオブジェクト定義のエラーです。」
Set rngDate = .Offset(, 1).Resize(, lngCol)

このエラーの回避方法で現在躓いています。
「該当する日付が見当たりません」などmsgboxの表示を試していますが
なかなか上手くいかない次第です。


>>いいえ元ファイルに列見出しは無いです。
>>一つ教えて頂きたいのですが
>>If VarType(vntField) = vbArray + vbVariant Then
>>はどのような意味になるのでしょうか?
>>
>>
>>    '日付の有る範囲を取得
>>    If lngCol = 0 Then
>>      '指定されたファイルをOpen
>>      '日付の列が1つも無い場合後の処理が面倒なので
>>      '先にファイル先頭の日付を入れて置く
>>      dfn = FreeFile
>>      Open vntFileName For Input As dfn
>>      If Not EOF(dfn) Then
>>        'ファイルから1行読み込み
>>        Line Input #dfn, strBuff
>>        'フィールドに分割
>>        vntField = Split(strBuff, ",", , vbBinaryCompare)
>>      End If
>>      Close #dfn
>>      If VarType(vntField) = vbArray + vbVariant Then
>>        'ファイルから取得した日付書き込み
>>        .Offset(, 1).Value = vntField(0)
>>        lngCol = 1
>>      Else
>>        blnWayOut = True
>>        GoTo WayOut
>>      End If
>>    End If
>
>「If VarType(vntField) = vbArray + vbVariant Then」
>此れは、vntFieldの変数が、Variant型の配列で有るか、否かを判定しています
>もし、vntFileNameで読み込もうとしたファイルが、ファイル其の物は有るが
>中身が無い場合(ファイルサイズが0)が有るので、其のエラー対策です
>
>所で、コード自体は上手く動かないのですか?
>其れが知りたいのですが?

【20761】Re:表へのCSVデータ挿入について
回答  Hirofumi  - 04/12/17(金) 22:19 -

引用なし
パスワード
   >ありがとうございます。
>初回のみ日付を入れれば問題なく動作はします。
>初回の日付が抜けていると下記エラーになるため
>リセットをかけて再施行になります。
>
>「アプリケーション定義またはオブジェクト定義のエラーです。」
>Set rngDate = .Offset(, 1).Resize(, lngCol)
>
>このエラーの回避方法で現在躓いています。
>「該当する日付が見当たりません」などmsgboxの表示を試していますが
>なかなか上手くいかない次第です。

変ですね?
其の様に直す事自体は簡単なのですが?
何か、私のコードから変更していますか?
私の方のテストでは、初回の日付が無くても動いていますが?

>「アプリケーション定義またはオブジェクト定義のエラーです。」
>Set rngDate = .Offset(, 1).Resize(, lngCol)

が出るのは、lngColが0だと成ると思います
其の原因は、

    If lngCol = 0 Then
      '指定されたファイルをOpen
      '日付の列が1つも無い場合後の処理が面倒なので
      '先にファイル先頭の日付を入れて置く
      dfn = FreeFile

以降の文が実行されてないからです
デバグしてもらえる解るのですが?

    If lngCol = 0 Then

に、ブレークポイントを置いて実行します
実行すると、上記の位置でブレークします
F8を押して、ステップ実行します
この時、

        'ファイルから取得した日付書き込み
        .Offset(, 1).Value = vntField(0)
        lngCol = 1

この行を実行しているか確認して下さい
多分、実行していないので、何処の行から飛んでいるのかが知りたいのですが?

また、不本意ながら、ディノさんの言う様に修正する場合の方法も書いて置きます
以下の部分を修正してください

    If lngCol = 0 Then
      '指定されたファイルをOpen
      '日付の列が1つも無い場合後の処理が面倒なので
      '先にファイル先頭の日付を入れて置く
      dfn = FreeFile
      Open vntFileName For Input As dfn
      If Not EOF(dfn) Then
        'ファイルから1行読み込み
        Line Input #dfn, strBuff
        'フィールドに分割
        vntField = Split(strBuff, ",", , vbBinaryCompare)
      End If
      Close #dfn
      If VarType(vntField) = vbArray + vbVariant Then
        'ファイルから取得した日付書き込み
        .Offset(, 1).Value = vntField(0)
        lngCol = 1
      Else
        blnWayOut = True
        GoTo WayOut
      End If
    End If


    If lngCol = 0 Then
      blnWayOut = True
      GoTo WayOut
    End If

とします、そして

  If blnWayOut Then
    MsgBox "ファイルが空です"
  Else
    MsgBox "処理が完了しました"
  End If


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

に修正します

【20763】Re:表へのCSVデータ挿入について
回答  Hirofumi  - 04/12/17(金) 23:04 -

引用なし
パスワード
   後、今気がついてのですが、
此れを書いているのがExcel97で本来、Split関数が無い為に代替の関数を使っています
其の為、一部コードを替えなければ成らない所が有りました

      If VarType(vntField) = vbArray + vbVariant Then

の所で、本来のSplit関数が返す配列が、バリアント型の配列では無く、
String型の配列を返す為、以下の様に変更して下さい

      If VarType(vntField) = vbArray + vbString Then

【20767】Re:表へのCSVデータ挿入について
お礼  ディノ  - 04/12/18(土) 0:15 -

引用なし
パスワード
   ▼Hirofumi さん:
ありがとうございます。
日付が無くても表示出来ました。

現在マクロを理解するのに奮闘中です。

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