Excel VBA質問箱 IV

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

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


69251 / 76732 ←次へ | 前へ→

【11999】Re:別シートに必要なデータだけ貼り付けたい
回答  Hirofumi E-MAIL  - 04/3/21(日) 14:18 -

引用なし
パスワード
   社員のデータはCsvファイルで、以下の様に成っていると想定します

1,12,13,25
2,5,60,20
3,4,8,7

出力する、シートは、以下の様に成っていると想定します

NO  C   A
1
3

NOは、1行目A列に有る物とします

このコードでは、社員のデータのCsvファイルをBookに展開せず
Openステートメントを使って1行づつ読み込み、
ActiveWorkbookのActiveSheetのNoを探して書きこんで行きます
Dictionary オブジェクトが使える環境なら、簡単なコードでは有りませんが
Findで探すより幾らか早いと思います

以下を標準モジュールに記述して下さい

Option Explicit

Public Sub DataExtraction()

  Dim i As Long
  Dim j As Long
  Dim dfn As Integer
  Dim vntFileName As Variant
  Dim strBuff As String
  Dim vntField As Variant
  Dim wksResult As Worksheet
  Dim vntResult As Variant
  Dim lngWrite As Long
  Dim lngEnd As Long
  Dim dicIndex As Object
  
  '結果書き込みシートの参照を設定
  Set wksResult = ActiveWorkbook.ActiveSheet
  '書き込み行の初期値を設定
  lngWrite = 2
  
  '社員データのファイル名を取得
  If Not GetReadFile(vntFileName, _
          ThisWorkbook.Path, False) Then
    GoTo ExitHandler
  End If
  
  With wksResult
    '探索範囲(No)の有る最終行取得
    lngEnd = .Cells(65536, "A").End(xlUp).Row
    '探索範囲(No)が無い場合
    If lngEnd < lngWrite Then
      Beep
      MsgBox "データが有りません"
      GoTo ExitHandler
    End If
    '探索範囲(No)の値を配列に取得
    vntResult = Range(.Cells(lngWrite, "A"), _
              .Cells(lngEnd, "B")).Value
  End With
    
  'Dictionary オブジェクトのインスタンスを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  '社員データのファイルをOpen
  dfn = FreeFile
  Open vntFileName For Input As dfn

  'Dictionaryに就いて
  With dicIndex
    For i = 1 To UBound(vntResult, 1)
      '探索範囲(No)の値をdicIndexにセット、
      .Add CLng(vntResult(i, 1)), i
      '及び結果用配列を初期化
      For j = 1 To 2
        vntResult(i, j) = Empty
      Next j
    Next i
    Do Until EOF(dfn)
      '社員データから1行読み込み
      Line Input #dfn, strBuff
      '読み込んだレコードをフィールドに分割
      vntField = SplitCsv(strBuff, ",")
      'Dictionaryに有った場合
      If .Exists(CLng(vntField(0))) Then
        i = .Item(CLng(vntField(0)))
        '結果用配列に列を入れ替えて代入
        vntResult(i, 1) = vntField(3)
        vntResult(i, 2) = vntField(1)
      End If
    Loop
  End With
  
  '社員データのファイルをClose
  Close #dfn
  
  '結果を結果用シートに出力
  With wksResult
    .Cells(lngWrite, _
        "B").Resize(UBound(vntResult, 1), 2) _
                      = vntResult
  End With
  
  Beep
  MsgBox "処理が終了しました"
  
ExitHandler:
    
  Set wksResult = Nothing
  Set dicIndex = Nothing
  
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

' Csvレコード分割関数

'      strLine     :分割元と成る文字列
'      strDelimiter  :区切り文字
'      SplitCsv    :戻り値、切り出された文字配列

  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim i As Long
  Dim vntField As String
  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)
        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 = ""
    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, False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function
0 hits

【11927】別シートに必要なデータだけ貼り付けたい かを 04/3/18(木) 18:38 質問
【11930】Re:別シートに必要なデータだけ貼り付けたい IROC 04/3/18(木) 18:47 回答
【11931】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/18(木) 19:00 発言
【11933】Re:別シートに必要なデータだけ貼り付けたい IROC 04/3/18(木) 20:48 回答
【11947】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/19(金) 9:24 発言
【11948】Re:別シートに必要なデータだけ貼り付けたい Asaki 04/3/19(金) 9:45 回答
【11950】Re:別シートに必要なデータだけ貼り付けたい IROC 04/3/19(金) 10:09 回答
【11953】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/19(金) 10:54 発言
【11955】Re:別シートに必要なデータだけ貼り付けたい IROC 04/3/19(金) 11:11 回答
【11963】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/19(金) 14:21 発言
【11965】Re:別シートに必要なデータだけ貼り付けたい Asaki 04/3/19(金) 15:00 回答
【11968】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/19(金) 15:58 発言
【11969】Re:別シートに必要なデータだけ貼り付けたい Asaki 04/3/19(金) 16:25 回答
【11974】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/19(金) 19:11 発言
【11982】Re:別シートに必要なデータだけ貼り付けたい Asaki 04/3/20(土) 14:47 回答
【11998】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/21(日) 11:58 発言
【12000】Re:別シートに必要なデータだけ貼り付けたい Asaki 04/3/21(日) 16:40 回答
【11999】Re:別シートに必要なデータだけ貼り付けたい Hirofumi 04/3/21(日) 14:18 回答
【12011】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/22(月) 10:23 お礼

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