Excel VBA質問箱 IV

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

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


7365 / 13645 ツリー ←次へ | 前へ→

【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 お礼[未読]

【39480】重複データから最新データのみ別のシート...
質問  kaoru  - 06/6/25(日) 9:50 -

引用なし
パスワード
   いつもお世話になっております。
シートAまたはテキストファイルで

  a     b    c
山田太郎 2006/04/05 7500
山田太郎 2006/05/12 8700
山本花子 2006/04/01 6700
山本花子 2006/04/05 5600
山田一郎 2005/08/19 1400

のデータを別のシートbへ

山田太郎 2006/05/12 8700
山本花子 2006/04/05 5600
山田一郎 2005/08/19 1400

最新日付分のみ抽出できますかね?
b列の日付は文字です。
よろしくお願いいたします。

【39481】Re:重複データから最新データのみ別のシ...
回答  だるま WEB  - 06/6/25(日) 10:58 -

引用なし
パスワード
   ▼kaoru さん:
>いつもお世話になっております。
>シートAまたはテキストファイルで
>
>  a     b    c
>山田太郎 2006/04/05 7500
>山田太郎 2006/05/12 8700
>山本花子 2006/04/01 6700
>山本花子 2006/04/05 5600
>山田一郎 2005/08/19 1400
>
>のデータを別のシートbへ
>
>山田太郎 2006/05/12 8700
>山本花子 2006/04/05 5600
>山田一郎 2005/08/19 1400
>
>最新日付分のみ抽出できますかね?
>b列の日付は文字です。
>よろしくお願いいたします。

こんにちは

D列に「=IF(A1=A2,"",1)」というような式を書けば対象行のみ「1」と表示されます
のでそれをオートフィルタなどで抽出すれば良いと思いますけどだめですか。^d^

【39483】Re:重複データから最新データのみ別のシ...
回答  Hirofumi  - 06/6/25(日) 13:33 -

引用なし
パスワード
   テキストファイルが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

【39490】Re:重複データから最新データのみ別のシ...
回答  Kein  - 06/6/25(日) 15:06 -

引用なし
パスワード
   だるまさんの数式を使うなら

Sub Copy_NewData()
  On Error Resume Next
  With Range("A1", Range("A65536").End(xlUp)).Offset(, 255)
   .Formula = "=IF($A1=$A2,"""",1)"
   Intersect(.SpecialCells(3, 1).EntireRow, Range("A:C")) _
   .Copy Sheets("B").Range("A1")
   .ClearContents
  End With
  Sheets("B").Activate
End Sub

Sheets("A") をアクティブにしてから実行して下さい。

【39561】Re:重複データから最新データのみ別のシ...
お礼  kaoru  - 06/6/26(月) 19:56 -

引用なし
パスワード
   ▼だるま さん:
だるまさん、ご返事が遅くありすみませんでした。
早速試してみます。ありがとうございます。

>
>D列に「=IF(A1=A2,"",1)」というような式を書けば対象行のみ「1」と表示されます
>のでそれをオートフィルタなどで抽出すれば良いと思いますけどだめですか。^d^

【39562】Re:重複データから最新データのみ別のシ...
お礼  kaoru  - 06/6/26(月) 19:59 -

引用なし
パスワード
   ▼Kein さん:
 keinさん、ご返事が遅くなりすみませんでした。
 早速試してみます。
 ありがとうございます。
>だるまさんの数式を使うなら
>
>Sub Copy_NewData()
>  On Error Resume Next
>  With Range("A1", Range("A65536").End(xlUp)).Offset(, 255)
>   .Formula = "=IF($A1=$A2,"""",1)"
>   Intersect(.SpecialCells(3, 1).EntireRow, Range("A:C")) _
>   .Copy Sheets("B").Range("A1")
>   .ClearContents
>  End With
>  Sheets("B").Activate
>End Sub
>
>Sheets("A") をアクティブにしてから実行して下さい。

【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

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