| |
かみちゃん さん、VBWASURETAさん、neptuneさん：
いろいろご指導ありがとうございました。
教えていただいたこととVBAサイトなどを参考にして
希望通りの結果を得ることができました。
とても感謝いたします。
どうもありがとうございました。
ちなみに、今まで作成したコードを下に記入して置きます。
Sub Books2Sheet()
Dim Fld As String
Dim fn As String
Dim Book As Workbook
Dim rngDest As Range
Dim myPath As String
Dim myBookName As String
Dim mySheet As Worksheet
Application.ScreenUpdating = False
Fld = フォルダ選択() 'フォルダ選択 Function参照
' If Fld = "" Then Exit Sub
'
' Fn = Dir(Fld & "\NVM_TW*_*.csv") '選択したフォルダ内のNVM_TW*_*.csvファイルを参照
' If Fn = "" Then Exit Sub 'そのようなファイルがなければExit Sub
myPath = Fld & "\"
myBookName = Dir(myPath & "ABC_TW*_*.csv") '選択されたファイル名をmyBookName変数にいれる
If myBookName = "" Then
MsgBox myPath & " に対象ファイルがありません"
Exit Sub '何も選択されたファイルがなければ、Exit Sub
End If
' Set Book = Workbooks.Add '新しいブックをセットする
' Set rngDest = Workbooks.Add.Worksheets(1).Range("A4")
' Set rngDest = Book.Worksheets(1).Range("A4")
Set rngDest = ThisWorkbook.Worksheets("縦NVM").Range("A4")
If MsgBox("4行目以下を消去しますか？", vbYesNo) = vbYes Then
rngDest.Parent.Cells.Resize(Rows.Count - 3).Offset(3).ClearContents
End If
Do Until myBookName = ""
If myBookName = ThisWorkbook.Name Then
Else
With Workbooks.Open(myPath & myBookName)
For Each mySheet In .Worksheets
With mySheet.Range("C21:C163")
'---
'開いたファイルの特定のセル範囲をコピーして、「形式を選択して貼り付け」の「値」と同時に「行列を入れ替える」
'.Copy
'rngDest.Offset(, 3).PasteSpecial Paste:=xlPasteValues, _
' Operation:=xlNone, SkipBlanks:=False, Transpose:=True
'Application.CutCopyMode = False
'---
'開いたファイルの特定のセル範囲の値を縦横を入れ替えて別のセル範囲の値にする
rngDest.Offset(, 3).Resize(.Columns.Count, .Rows.Count).Value = WorksheetFunction.Transpose(.Value)
End With
With mySheet 'A1からC1までのセル値を取得する
rngDest.Resize(, 3).Value = Array(Replace(.Range("A1").Value, "// ", ""), .Range("B1").Value, .Range("C1").Value)
'rngDest.Resize(, 3).Value = .Range("A1:C1").Value
Set rngDest = rngDest.Offset(1)
End With
'' With mySheet.Range("A1", "C1") 'A1からC1までのセル値を取得する
' With mySheet.Range("A1:C1") 'A1からC1までのセル値を取得する
' ''With mySheet.UsedRange
' .Copy rngDest
' Set rngDest = rngDest.Offset(.Rows.Count)
' End With
Next
.Close False
End With
End If
myBookName = Dir()
Loop
'結果物のA列はファイル名と関係なく日付順で並べ替える
With rngDest
With .Offset((.Row - 4) * -1).Resize(.Row - 4)
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End With
End With
Application.ScreenUpdating = True
MsgBox "完了！"
End Sub
Private Function フォルダ選択(Optional Title As String = "Missing", Optional RootFolder As Variant) As String
Dim Shl As Object 'Shell32.Shell
Dim Fld As Object 'Folder
Dim strFld As String
Dim Ttl As String
If Title = "Missing" Then
Ttl = "合体前のcsvファイルがあるフォルダを選択してください。"
Else
Ttl = Title
End If
Set Shl = CreateObject("Shell.Application")
'1:コントロールパネルなどの余分なもの非表示 512:新規フォルダ作成ボタン非表示
If IsMissing("RootFolder") Then
Set Fld = Shl.BrowseForFolder(0, Ttl, 1 + 512)
Else
Set Fld = Shl.BrowseForFolder(0, Ttl, 1 + 512, RootFolder)
End If
strFld = ""
If Not Fld Is Nothing Then
On Error Resume Next
strFld = Fld.Self.path
If strFld = "" Then
strFld = Fld.Items.Item.path
End If
On Error GoTo 0
End If
If InStr(strFld, "\") = 0 Then strFld = ""
フォルダ選択 = strFld
Set Shl = Nothing
Set Fld = Nothing
End Function
他にこのような問題で困っている方に参考になれればいいと思います。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 08/2/18(月) 18:18 -
