Excel VBA質問箱 IV

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

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


20455 / 76732 ←次へ | 前へ→

【61695】Re:新しいブックを作成するVBA
回答  Hirofumi  - 09/5/28(木) 7:58 -

引用なし
パスワード
   こんなかな?
ただ、B列はIDで日付はA列に成っているのですが?

Option Explicit

Public Sub Sample()

  '出力するファイルの拡張子
  Const cstrExten As String = ".xls"
  
  Dim i As Long
  Dim lngRows As Long
  Dim lngColumns As Long
  Dim rngList As Range
  Dim rngHeader As Range
  Dim vntBookName As Variant
  Dim dicIndex As Object
  Dim strProm As String
  
  '◆「抽出データ」の先頭セル位置を基準とする(先頭列の列見出し「日付」のセル位置)
  Set rngList = Worksheets("Sheet1").Range("A1")
  
  '「抽出データ」の表に就いて
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '列見出し列数の取得
    lngColumns = .Offset(, Columns.Count - _
            .Column).End(xlToLeft).Column - .Column + 1
    '列見出し範囲の取得
    Set rngHeader = .Resize(, lngColumns)
  End With
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Key列に就いて繰り返し
  For i = 1 To lngRows
    'データ列数の取得
    With rngList
      lngColumns = .Offset(i, Columns.Count - _
              .Column).End(xlToLeft).Column - .Column + 1
      'B列?の値取得(日付はA列ですが?)
'      vntBookName = .Offset(i, 1).Value
      'A列の日付値取得
      vntBookName = Format(.Offset(i).Value, "yyyymmdd")
    End With
    With dicIndex
      '出力Book名の取得
      .Item(vntBookName) = .Item(vntBookName) + 1
      'Book名の作成
      vntBookName = ThisWorkbook.Path & "\" & vntBookName & "-" _
              & .Item(vntBookName) & cstrExten
    End With
    '1Book分の転記
    DataTransfer rngHeader, rngList.Offset(i).Resize(, lngColumns), vntBookName
  Next i
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set dicIndex = Nothing
  Set rngList = Nothing
  Set rngHeader = Nothing
  
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DataTransfer(rngHeader As Range, _
            rngOutput As Range, _
            vntBookName As Variant)

'  1Book分の転記

  '出力シートの出力位置
  Const cstrTop As String = "A1"
  
  Dim rngResult As Range
  
  'Bookを追加してSheetのA1を基準とします
  Set rngResult = Workbooks.Add.Worksheets(1).Range("A1")
  
  With rngResult
    '列見出しを出力
    rngHeader.Copy Destination:=.Cells(1, 1)
    'データを転記
    rngOutput.Copy Destination:=.Offset(1)
    '新規Bookを名前を付けて保存します
    Application.DisplayAlerts = False
    With .Parent.Parent
      .SaveAs Filename:=vntBookName
      'Excel2007の場合
'      .SaveAs Filename:=vntBookName, FileFormat:=xlExcel8
      .Close
    End With
    Application.DisplayAlerts = True
  End With
  
  Set rngResult = Nothing
  
End Sub

0 hits

【61694】新しいブックを作成するVBA VBAド素人 09/5/28(木) 3:48 質問
【61695】Re:新しいブックを作成するVBA Hirofumi 09/5/28(木) 7:58 回答
【61715】Re:新しいブックを作成するVBA VBAド素人 09/5/28(木) 22:44 お礼
【61699】Re:新しいブックを作成するVBA 具頭幸憲 09/5/28(木) 11:15 回答
【61718】Re:新しいブックを作成するVBA VBAド素人 09/5/29(金) 2:19 お礼
【61717】新しいブックを作成するVBA⇒プラスα VBAド素人 09/5/28(木) 23:08 質問
【61719】Re:新しいブックを作成するVBA⇒プラスα Hirofumi 09/5/29(金) 8:17 回答
【61734】Re:新しいブックを作成するVBA⇒プラスα VBAド素人 09/5/30(土) 13:09 質問
【61738】Re:新しいブックを作成するVBA⇒プラスα Hirofumi 09/5/30(土) 17:31 回答
【61740】Re:新しいブックを作成するVBA⇒プラスα VBAド素人 09/5/30(土) 19:13 お礼

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