Excel VBA質問箱 IV

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

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


67107 / 76738 ←次へ | 前へ→

【14190】Re:エクセルVBAの記述
回答  Hirofumi E-MAIL  - 04/5/22(土) 21:06 -

引用なし
パスワード
   チョット長くなるけど(大分かな?)こんな事なのかな?
test.xlsのマクロを削除するのでは無く、
マクロの有るBookからtest.xlsをOpenし、このBookにシートを追加して
其処に、Csvファイルを読み込み、最後にファイル名に日付を付加してSaveします
尚、test.xlsは、シートを追加するのでSheet1だけにして下さい
また、Csvファイルは、GetOpenFileNameのダイアログを出して複数選択する様にして有りますが
フォルダを指定しておいて、其処のCsvファイルを読む様にする場合
「「ファイルを開く」ダイアログを複数選択で表示」以下の3行を削除して
「指定フォルダ内の".csv"ファイルを全て開く場合」を活かして下さい

以下をマクロを組み込むBookの標準モジュールに記述して下さい

Option Explicit

Public Sub CsvDataRead()

  Dim i As Long
  Dim vntFileNames As Variant
  Dim lngWriteRow As Long
  Dim wksWrite As Worksheet
  Dim strPath As String
  Dim strSheetName As String
  Dim strSavePath As String
  
  'Csvファイルを読み込むBookをOpen
  Workbooks.Open ThisWorkbook.Path & "\" & "test.xls"
'  Workbooks.Open "C:\○\デスクトップ\" & "test.xls"
  'BookをSaveするフォルダを取得
  strSavePath = ActiveWorkbook.Path
  
  'Csvファイルの有るフォルダを指定
  strPath = ActiveWorkbook.Path
'  strPath = "C:\○○\csv"
  
  'ファイル名の範囲指定で開く場合
  '「ファイルを開く」ダイアログを複数選択で表示
  If Not GetReadFile(vntFileNames, strPath, True) Then
    Exit Sub
  End If
  
'  '指定フォルダ内の".csv"ファイルを全て開く場合
'  If Not SearchFiles(vntFileNames, strPath, "k*.csv") Then
'    Exit Sub
'  End If
  
'  Application.ScreenUpdating = False
    
  '複数選択されたファイルをシートに出力
  For i = 1 To UBound(vntFileNames)
    'シート名を作成
    strSheetName _
      = GetFileName(vntFileNames(i))
    strSheetName _
      = GetSheetName(strSheetName)
    'アクティブBookにシートを追加
    With ActiveWorkbook.Worksheets
      '出力シートを設定
      Set wksWrite _
        = .Add(After:=Worksheets(.Count))
    End With
    With wksWrite
      .Columns("A:E").NumberFormat = "@"
      'シート名を変更
      .Name = strSheetName
    End With
    '出力する先頭行を設定
    lngWriteRow = 1
    'CSVを書き込み
    CSVRead vntFileNames(i), _
          wksWrite, lngWriteRow, 1
    wksWrite.Columns.AutoFit
  Next i
  Set wksWrite = Nothing

  '"test.xls"に日付を付けてSave
  With ActiveWorkbook
    .SaveAs GetFileName(ActiveWorkbook.Name) _
          & Format(Date, "mmdd") & ".xls"
    .Close
  End With
  
'  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Sub CSVRead(ByVal strFileName As String, _
              ByVal wksWrite As Worksheet, _
              Optional ByRef lngRow As Long = 1, _
              Optional ByRef lngCol As Long = 1)
  
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  
  '空きファイルバファ番号を取得
  dfn = FreeFile
  'ファイルをInputモードで開く
  Open strFileName For Input As dfn
  
  'ファイルエンドまで繰り返し
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'レコードをフィールドに分割
    vntField = SplitCsv(strBuff, ",")
        
    '指定シートの指定列、行について
    With wksWrite.Cells(lngRow, lngCol)
      '結果配列を代入
      .Offset.Resize(, UBound(vntField) + 1) = vntField
    End With
    '書き込み行を更新
    lngRow = lngRow + 1
  Loop
  
  'ファイルをClose
  Close #dfn
  
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

  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 blnMulti As Boolean = False) As Boolean

  Dim strFilter As String

  strFilter = "CSV File (*.csv),*.csv," _
        & "全て (*.*),*.*"
  If strFilePath <> "" Then
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  If vntFileNames <> "" Then
    SendKeys vntFileNames, False
  End If
  vntFileNames _
    = Application.GetOpenFilename(strFilter, 1, , , blnMulti)
  If Not VarType(vntFileNames) = vbBoolean Then
    GetReadFile = True
  End If
  
End Function

Private Function SearchFiles(vntFileNames As Variant, _
            strFilePath As String, _
            strFile As String) As Variant

  Dim i As Long
  Dim lngEnd As Long
  
  With Application.FileSearch
    .LookIn = strFilePath
    .FileName = strFile
    If .Execute(SortBy:=msoSortByFileName, _
        SortOrder:=msoSortOrderAscending) > 0 Then
      If VarType(vntFileNames) = vbEmpty Then
        lngEnd = 0
        ReDim vntFileNames(1 To .FoundFiles.Count)
      Else
        lngEnd = UBound(vntFileNames)
        ReDim Preserve _
          vntFileNames(1 To lngEnd + .FoundFiles.Count)
      End If
      For i = 1 To .FoundFiles.Count
        vntFileNames(lngEnd + i) = .FoundFiles(i)
      Next i
      SearchFiles = True
    End If
  End With
        
End Function

Private Function GetSheetName(ByVal strName As String) As String

  Dim i As Long
  Dim lngPos As Long
  Dim lngNumb As Long
  Dim lngTmpNumb As Long
  Dim strSName As String
  
  lngPos = Len(strName) + 1
  lngNumb = -1
  With ActiveWorkbook
    For i = 1 To .Worksheets.Count
      strSName = .Worksheets(i).Name
      If strSName Like strName & "*" Then
        Select Case Mid(strSName, lngPos, 1)
          Case ""
            lngTmpNumb = 0
          Case "("
            lngTmpNumb _
                = InStr(1, strSName, ")", _
                        vbBinaryCompare)
            If lngTmpNumb > 0 Then
              lngTmpNumb _
                = Val(Mid(strSName, lngPos + 1, _
                    lngTmpNumb - lngPos - 1))
            Else
              lngTmpNumb _
                = Val(Mid(strSName, lngPos + 1))
            End If
          Case Else
            lngTmpNumb = -1
        End Select
        If lngNumb < lngTmpNumb Then
          lngNumb = lngTmpNumb
        End If
      End If
    Next i
  End With
  
  If lngNumb = -1 Then
    GetSheetName = strName
  Else
    GetSheetName = strName & "(" & (lngNumb + 1) & ")"
  End If

End Function

Private Function GetFileName(ByVal strName As String) As String

'  ファイル名をPathから分離

  Dim i As Long
  Dim lngPos As Long
  
  i = 0
  lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Do Until lngPos = 0
    i = lngPos
    lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Loop
  strName = Mid(strName, i + 1)
  i = 1
  lngPos = InStr(i, strName, ".", vbBinaryCompare)
  Do Until lngPos = 0
    i = lngPos
    lngPos = InStr(i + 1, strName, ".", vbBinaryCompare)
  Loop
  GetFileName = Left(strName, i - 1)
  
End Function

0 hits

【14159】エクセルVBAの記述 さる 04/5/22(土) 12:18 質問
【14161】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 12:49 回答
【14164】Re:エクセルVBAの記述 さる 04/5/22(土) 13:11 質問
【14178】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 15:15 回答
【14179】Re:エクセルVBAの記述 さる 04/5/22(土) 15:20 質問
【14180】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 15:47 発言
【14181】Re:エクセルVBAの記述 さる 04/5/22(土) 16:14 質問
【14182】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 16:23 回答
【14183】Re:エクセルVBAの記述 さる 04/5/22(土) 16:31 質問
【14184】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 16:56 発言
【14185】Re:エクセルVBAの記述 さる 04/5/22(土) 17:38 質問
【14190】Re:エクセルVBAの記述 Hirofumi 04/5/22(土) 21:06 回答
【14188】Re:エクセルVBAの記述 かみちゃん 04/5/22(土) 18:35 発言

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