Excel VBA質問箱 IV

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

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


28036 / 76732 ←次へ | 前へ→

【54007】解決しました。どうもありがとうございました。
お礼  cpdim1 E-MAIL  - 08/2/20(水) 0:30 -

引用なし
パスワード
   かみちゃん さん、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


他にこのような問題で困っている方に参考になれればいいと思います。
0 hits

【53960】[難題相談]フォルダ内の*.csvファイルを統合し、データをまとめる cpdim 08/2/18(月) 16:45 質問
【53962】Re:[難題相談]フォルダ内の*.csvファイルを... かみちゃん 08/2/18(月) 18:18 発言
【53963】Re:[難題相談]フォルダ内の*.csvファイルを... cpdim 08/2/18(月) 18:41 お礼
【53964】Re:[難題相談]フォルダ内の*.csvファイルを... かみちゃん 08/2/18(月) 18:57 発言
【53970】Re:[難題相談]フォルダ内の*.csvファイルを... cpdim 08/2/19(火) 9:54 お礼
【53971】Re:[難題相談]フォルダ内の*.csvファイルを... かみちゃん 08/2/19(火) 10:00 発言
【53978】Re:[難題相談]フォルダ内の*.csvファイルを... cpdim 08/2/19(火) 14:48 お礼
【53993】Re:[難題相談]フォルダ内の*.csvファイルを... かみちゃん 08/2/19(火) 17:27 発言
【53996】Re:[難題相談]フォルダ内の*.csvファイルを... cpdim 08/2/19(火) 18:00 質問
【54003】Re:[難題相談]フォルダ内の*.csvファイルを... neptune 08/2/19(火) 23:13 発言
【54007】解決しました。どうもありがとうございまし... cpdim1 08/2/20(水) 0:30 お礼
【53972】Re:[難題相談]フォルダ内の*.csvファイルを... VBWASURETA 08/2/19(火) 10:06 回答
【53973】Re:[難題相談]フォルダ内の*.csvファイルを... VBWASURETA 08/2/19(火) 10:12 発言

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