Excel VBA質問箱 IV

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

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


42240 / 76732 ←次へ | 前へ→

【39563】Re:重複データから最新データのみ別のシートへ
お礼  kaoru  - 06/6/26(月) 20:01 -

引用なし
パスワード
   ▼Hirofumi さん:
 Hirofumiさんご返事が遅くなり申し訳ございません
 早速試してみます。ありがとうございました。すごいですね〜!
>テキストファイルがCSV(カンマ区切り)のデータとした場合の読み込みです
>
>Option Explicit
>
>Public Sub CSVRead()
>  
>'  CSVデータの読み込み
>  
>  Dim i As Long
>  Dim rngWrite As Range
>  Dim lngRow As Long
>  Dim lngPos As Long
>  Dim strPath As String
>  Dim dfn As Integer
>  Dim vntFileNames As Variant
>  Dim vntField As Variant
>  Dim strBuff As String
>  Dim dicIndex As Object
>  Dim vntResult As Variant
>  Dim blnWrite As Boolean
>  Dim strProm As String
>  
>  '書き込む位置を設定
>  Set rngWrite = ActiveSheet.Cells(1, "A")
>  rngWrite.Offset(, 1).EntireColumn.NumberFormatLocal = "yyyy/mm/dd"
>  
>  '読み込むファイルのフォルダを設定
>  strPath = ThisWorkbook.Path
>'  strPath = "E:\Office2000\Excel\Test6\TestData"
>  
>  '指定フォルダからファイル名を取得
>  If Not GetReadFile(vntFileNames, strPath, False) Then
>    strProm = "マクロがキャンセルされました"
>    GoTo Wayout
>  End If
>  
>  'Dictionaryオブジェクトを取得
>  Set dicIndex = CreateObject("Scripting.Dictionary")
>
>  '画面更新を停止
>'  Application.ScreenUpdating = False
>  
>  '指定ファイルを読み込みモードでOpen
>  dfn = FreeFile
>  Open vntFileNames For Input As dfn
>  
>  'ファイルエンドまで繰り返し
>  Do Until EOF(dfn)
>    'ファイルから1行読み込み
>    Line Input #dfn, strBuff
>    'CSVをフィールドに分割
>    vntField = SplitCsv(strBuff, ",")
>    '書き込みFlagをTrueに
>    blnWrite = True
>    With dicIndex
>      'Indexに名前の登録が有るなら
>      If .Exists(vntField(0)) Then
>        'Listの出力位置を取得
>        lngPos = .Item(vntField(0))
>        'Listから該当データを取得
>        vntResult = rngWrite.Offset(lngPos) _
>                .Resize(, UBound(vntField) + 1).Value
>        'もし、該当データの日付が新しいなら
>        If vntResult(1, 2) > DateValue(vntField(1)) Then
>          '書き込みFlagをFalseに
>          blnWrite = False
>        End If
>      Else
>        '最終行を書き込み位置にする
>        lngPos = lngRow
>        'Indexに名前をKeyとして出力行位置を登録
>        .Item(vntField(0)) = lngPos
>        '書き込み行位置を更新
>        lngRow = lngRow + 1
>      End If
>    End With
>    If blnWrite Then
>      '指定シートの指定行列位置にフィールドの書き込み
>      rngWrite.Offset(lngPos).Resize(, _
>            UBound(vntField) + 1).Value = vntField
>    End If
>  Loop
>  
>  'ファイルをClose
>  Close #dfn
>  
>  strProm = "処理が完了しました"
>  
>Wayout:
>  
>  '画面更新を再開
>  Application.ScreenUpdating = True
>  
>  'Dictionaryオブジェクトを破棄
>  Set dicIndex = Nothing
>  Set rngWrite = Nothing
>  
>  MsgBox strProm, vbInformation
>  
>End Sub
>
>Private Function SplitCsv(ByVal strLine As String, _
>            Optional strDelimiter As String = ",", _
>            Optional strQuote As String = """", _
>            Optional strRet As String = vbCrLf, _
>            Optional blnMulti As Boolean) As Variant
>
>'      strLine     :分割元と成る文字列
>'      strDelimiter  :区切り文字
>'      SplitCsv    :戻り値、切り出された文字配列
>
>  Dim lngDPos As Long
>  Dim vntData() As Variant
>  Dim lngStart As Long
>  Dim i As Long
>  Dim vntField As Variant
>  Dim lngLength As Long
>  
>  i = 0
>  lngStart = 1
>  lngLength = Len(strLine)
>  blnMulti = False
>  Do
>    ReDim Preserve vntData(i)
>    If Mid$(strLine, lngStart, 1) <> strQuote Then
>      lngDPos = InStr(lngStart, strLine, _
>            strDelimiter, vbBinaryCompare)
>      If lngDPos > 0 Then
>        vntField = Mid$(strLine, lngStart, _
>                  lngDPos - lngStart)
>        If lngDPos = lngLength Then
>          ReDim Preserve vntData(i + 1)
>        End If
>        lngStart = lngDPos + 1
>      Else
>        vntField = Mid$(strLine, lngStart)
>        lngStart = lngLength + 1
>      End If
>    Else
>      lngStart = lngStart + 1
>      Do
>        lngDPos = InStr(lngStart, strLine, _
>                strQuote, vbBinaryCompare)
>        If lngDPos > 0 Then
>          vntField = vntField & Mid$(strLine, _
>                lngStart, lngDPos - lngStart)
>          lngStart = lngDPos + 1
>          Select Case Mid$(strLine, lngStart, 1)
>            Case ""
>              Exit Do
>            Case strDelimiter
>              lngStart = lngStart + 1
>              Exit Do
>            Case strQuote
>              lngStart = lngStart + 1
>              vntField = vntField & strQuote
>          End Select
>        Else
>          blnMulti = True
>          vntField = Mid$(strLine, lngStart) & strRet
>          lngStart = lngLength + 1
>          Exit Do
>        End If
>      Loop
>    End If
>    vntData(i) = vntField
>    vntField = Empty
>    i = i + 1
>  Loop Until lngLength < lngStart
>  
>  SplitCsv = vntData()
>  
>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
1 hits

【39480】重複データから最新データのみ別のシートへ kaoru 06/6/25(日) 9:50 質問
【39481】Re:重複データから最新データのみ別のシー... だるま 06/6/25(日) 10:58 回答
【39490】Re:重複データから最新データのみ別のシー... Kein 06/6/25(日) 15:06 回答
【39562】Re:重複データから最新データのみ別のシー... kaoru 06/6/26(月) 19:59 お礼
【39561】Re:重複データから最新データのみ別のシー... kaoru 06/6/26(月) 19:56 お礼
【39483】Re:重複データから最新データのみ別のシー... Hirofumi 06/6/25(日) 13:33 回答
【39563】Re:重複データから最新データのみ別のシー... kaoru 06/6/26(月) 20:01 お礼

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