Excel VBA質問箱 IV

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

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


13216 / 76734 ←次へ | 前へ→

【69024】Re:並び順が不規則なデータを整列する
回答  UO3  - 11/5/10(火) 23:04 -

引用なし
パスワード
   ▼武藤 晃作 さん:

・まず、フォルダを1つ(任意の場所に)作成して、学生さんのブックを
 すべて、そこに保存してください。
・新規ブックの標準モジュールに以下を貼り付けてください。
 A列、C列の見出し語は実際のものに変更してください。
 また、学生さんのブック、処理後も閉じずにエクセル上に残していますが
 処理後は自動的に閉じたほうがよければ、コメントアウトしたクローズ命令を
 いかしてください。
・で、このマクロブックを任意の名前で上で作ったフォルダに保存した上で実行してください。

Sub Sample()
  Dim myPath As String
  Dim myBook As String
  Dim TitleA As String
  Dim TitleC As String
  Dim colA As Variant, colC As Variant
  
  Application.ScreenUpdating = False
  
  myPath = ThisWorkbook.Path
  TitleA = "項目A" '実際の見出し名にしてください。
  TitleC = "項目C" '実際の見出し名にしてください
  myBook = Dir(myPath & "\*.xls")
  
  Do While myBook <> ""
    If myBook <> ThisWorkbook.Name Then
      Workbooks.Open myPath & "\" & myBook
      With Worksheets(1)
        colA = Application.Match(TitleA, .Rows(1), 0)
        colC = Application.Match(TitleC, .Rows(1), 0)
        
        If Not IsNumeric(colA) Or Not IsNumeric(colC) Then
          MsgBox ActiveWorkbook.Name & "には所定の見出しがありません" & vbLf & _
              "処理をスキップします"
          ActiveWorkbook.Close savechanges:=False
        Else
          Sheets.Add after:=Sheets(Worksheets.Count)
          .Columns(colA).Copy Destination:=Range("A1")
          .Columns(colC).Copy Destination:=Range("B1")
          Application.CutCopyMode = False
          Application.DisplayAlerts = False
          
          'ActiveWorkbook.Close True  '必要ならこのコードを実行
          
          Application.DisplayAlerts = True
        End If
      End With
    End If
    myBook = Dir()
  Loop
  
  Application.ScreenUpdating = True
  
End Sub

5 hits

【69008】並び順が不規則なデータを整列する 武藤 晃作 11/5/7(土) 21:00 質問
【69009】Re:並び順が不規則なデータを整列する UO3 11/5/7(土) 21:08 発言
【69023】Re:並び順が不規則なデータを整列する 武藤 晃作 11/5/10(火) 22:01 質問
【69024】Re:並び順が不規則なデータを整列する UO3 11/5/10(火) 23:04 回答
【69038】Re:並び順が不規則なデータを整列する 武藤 晃作 11/5/11(水) 22:00 お礼

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