こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

ExcelのVBAに関して教えてください。

下記のようにCSVファイル名を複数入力してマクロ実行したら転記するようにしたいです。
やり方がわかる人いたら、教えてください。

(1)C10にa、C11にb、C12にc、C13にdを入力
(2)マクロ実行ボタンを押す
(3)aのcsvファイルのG12~G36をD10~D34に転記。 ※aのパスは¥¥mm¥nn¥cc¥a.csv
 bのcsvファイルのG12~G36をD35~D59に転記。 ※bのパスは¥¥mm¥nn¥yy¥b.csv
 cのcsvファイルのG12~G36をD60~D84に転記。 ※cのパスは¥¥mm¥nn¥kk¥c.csv
 dのcsvファイルのG12~G36D85~D109にを転記。※dのパスは¥¥mm¥nn¥bb¥d.csv

 難しい点は最下層のフォルダが異なっている点です。。
 最下層のフォルダ違うが、csvファイルを転記する方法はありませんか?

投稿日時 - 2018-11-05 22:55:47

QNo.9554919

困ってます

このQ&Aは役に立ちましたか?

2人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.3

Sub Test2()
Dim FSO As Object, myPath As String, strText As String
Dim c As Range, buf As Variant
Dim i As Long, j As Long, sr As Long

Set FSO = CreateObject("Scripting.FileSystemObject")
j = 10
For Each c In Range("C10", Cells(Rows.Count, "C").End(xlUp))
myPath = GetPath("\\mm\nn", c.Value & ".csv")
If myPath <> "" Then
With FSO.OpenTextFile(myPath, 1)
buf = .ReadAll
.Close
End With
buf = Split(buf, vbCrLf)
For i = 11 To 35
strText = Split(buf(i), ",")(6)
Cells(sr + j, "D").Value = strText
j = j + 1
Next
End If
Next
Set FSO = Nothing
End Sub
Function GetPath(Path As String, Target As String)
Dim FSO As Object, Folder As Variant, File As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each Folder In FSO.GetFolder(Path).SubFolders
For Each File In Folder.Files
If File.Name = Target Then
GetPath = File.Path
Exit Function
End If
Next
Next
GetPath = ""
Set FSO = Nothing
End Function

投稿日時 - 2018-11-06 22:07:38

ANo.2

参考に
Sub Test()
  Dim FSO As Object, myPath As String, strText As String
  Dim myRng As Range, c As Range, buf As Variant
  Dim i As Long, j As Long, sr As Long

  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set myRng = ActiveSheet.Columns("C:C").SpecialCells(xlCellTypeConstants)
  For Each c In myRng
    If c.Value Like "[a-d]" Then
      Select Case c.Value
        Case "a": sr = 10: myPath = "\\mm\nn\cc\a.csv"
        Case "b": sr = 35: myPath = "\\mm\nn\yy\b.csv"
        Case "c": sr = 60: myPath = "\\mm\nn\kk\c.csv"
        Case "d": sr = 85: myPath = "\\mm\nn\bb\d.csv"
      End Select
      With FSO.OpenTextFile(myPath, 1)
        buf = .ReadAll
        .Close
      End With
      buf = Split(buf, vbCrLf)
      j = 0
      For i = 11 To 35
        strText = Split(buf(i), ",")(6)
        Cells(sr + j, "D").Value = strText
        j = j + 1
      Next
    End If
  Next
  Set FSO = Nothing
End Sub

投稿日時 - 2018-11-06 08:43:32

補足

すみません。説明不足でした。
csvファイルは多数存在していて、e.csvやf.csvなども転記できる形にしたいです。
最下層のcsvファイルを取得するマクロなどはないでしょうか?

投稿日時 - 2018-11-06 19:44:26

ANo.1

(1)C10にa、C11にb、C12にc、C13にdを入力
というのは、プログラムで入力ということでしょうか、
それとも、手作業で入力して、そのファイル名でを読み取るということでしょうか。
前者だとします。

>最下層のフォルダが異なっている
こういう時は、テーブルを作るのが1番手っ取り早い。プログラム上に持つのは面倒です。
まず、新しいワークブックに、"Works" "Table" というシートを作ります(他のシートはいりません)
Table に図のように入力します。
このプログラムを入れ、実行します。
'
Option Explicit
'
Sub Macro1()
'
  Dim Table As Worksheet
  Dim Works As Worksheet
  Dim Row As Integer
  Dim InputArea As String
  Dim OutputArea As String
'
'  Application.ScreenUpdating = False
  Set Table = Sheets("Table")
  Set Works = Sheets("Works")
  Workbooks.Add
'
  For Row = 2 To Table.[A1].End(xlDown).Row
    Works.Cells.ClearContents
    InputArea = Table.Cells(Row, "A")
    Range(InputArea) = Table.Cells(Row, "B")
    InputArea = Table.Cells(Row, "C")
'
    With Works.QueryTables.Add("TEXT;" & InputArea, Works.[A1])
      .RefreshStyle = xlOverwriteCells
      .TextFileCommaDelimiter = True
      .Refresh False
    End With
    Works.[A1].QueryTable.Delete
    InputArea = Table.Cells(Row, "D")
    OutputArea = Table.Cells(Row, "E")
    Range(OutputArea) = Works.Range(InputArea).Value
  Next Row
End Sub

投稿日時 - 2018-11-06 06:03:46

補足

すみません。プログラム上で作成は無理でしょうか?
csvファイル名のみ入力してマクロ実行したら、転記できるようにしたいです。またa~d.csv以外にも複数csvファイルがある状況です。

投稿日時 - 2018-11-06 19:46:57

あなたにオススメの質問