Excel VBA質問箱 IV

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

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


60829 / 76732 ←次へ | 前へ→

【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
0 hits

【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 お礼

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