[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAについて非常に困っております。』（masamasa1736）
先駆者が作られたVBAがわからず困ってます。
このコードを使うと該当の箇所からエクセルが順次作られていきますが普通にコードを動かすとエクセルが作られる速度がかなり遅いです。そのため該当のデータを入力したあとにデータが入っているところの一番下以降と一番右以降の部分を全削除してからこのコードを行うとわりとスムーズにエクセルが作られます。この削除作業を行わないようにするにはどの部分を修正するか何コードを追加したらできるのか教えて頂きたいです。ちなみに配信一覧_11行目はA列全部が選択されており配信一覧_11行目2はA列からAS列全体を範囲にしておりました。
Sub ファイル作成11行目()
Application.ScreenUpdating = False
Set motoRng = Range("配信一覧_11行目")
myFld = 1
Set criRng = Range("抽出リスト")
Set motoRngAll = Range("配信一覧_11行目2")
Set windowset = Range("window")
Set Mypass = Range("password")
Dim tmpName As String
For Each tmpRng In criRng
' 該当シート作成
motoRng.AutoFilter myFld, tmpRng
Set tmpSht = Sheets.Add(after:=Worksheets(Sheets.Count))
' 不要なデータのコピーを削除
tmpSht.Name = tmpRng.Value
tmpSht.Range("A1").Resize(motoRng.Rows.Count, motoRng.Columns.Count).Value = motoRng.Value
' 列の削除処理を最適化
tmpSht.Columns("AOM:XFD").Delete Shift:=xlToLeft
' 範囲の選択と処理を最小限に
With tmpSht.UsedRange
.Font.Name = "Meiryo UI"
.Font.Size = 9
.Font.Size = 12
End With
' ファイル名指定
Application.DisplayAlerts = False
ActiveWorkbook.CheckCompatibility = False
'ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Range("A1") & "【" & tmpRng & "様】.xls", FileFormat:=xlWorkbookNormal, _ Password:="KDDI" & Mypass ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "【" & tmpRng & "様】" & Range("A1") & ".xlsx", FileFormat:=xlWorkbookDefault, _ Password:="KDDI" & Mypass 'ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "（" & tmpRng & "様）" & Range("A1") & ".xls", FileFormat:=xlWorkbookNormal, _ Password:="KDDI" & Mypass
' 差異見本選択して閉じる
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
' 元xlsの後片付け
Application.DisplayAlerts = False
Worksheets(tmpRng.Value).Delete
Application.DisplayAlerts = True
Next
ThisWorkbook.Activate
Application.Goto motoRng
ActiveSheet.ShowAllData
Application.ScreenUpdating = True
Sheets("設定").Select
MsgBox "11行目ファイル作成終了"
End Sub
＜ 使用 Excel：unknown、使用 OS：unknown ＞
Sub ファイル作成11行目()
Application.ScreenUpdating = False
Set motoRng = Range("配信一覧_11行目")
myFld = 1
Set criRng = Range("抽出リスト")
Set motoRngAll = Range("配信一覧_11行目2")
Set windowset = Range("window")
Set Mypass = Range("password")
Dim tmpName As String
For Each tmpRng In criRng
'該当シート作成
motoRng.AutoFilter myFld, tmpRng
Set tmpSht = Sheets.Add(after:=Worksheets(Sheets.Count))
motoRngAll.Copy
With tmpSht
.Range("A1").PasteSpecial 8
.Range("A1").PasteSpecial xlPasteAll
.Name = tmpRng.Value
End With
'xls新規作成
ActiveWindow.SelectedSheets.Copy
ActiveWorkbook.Worksheets(tmpRng.Value).Activate
'オートフィルターの設定
'ActiveSheet.Range("$A$3:$BK$3").AutoFilter
'Columns("A:D").Select
'Application.CutCopyMode = False
'Selection.Delete Shift:=xlToLeft
Columns("AOM:XFD").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Rows("20000:20000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
ActiveWindow.DisplayGridlines = False
Range(windowset.Value).Select
ActiveWindow.FreezePanes = True
Cells.Select
With Selection.Font
.Name = "Meiryo UI"
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("A1").Select
With Selection.Font
.Name = "Meiryo UI"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
'Cells.EntireColumn.AutoFit
'Range("A1").Select
'Columns("A:A").ColumnWidth = 25.5
ActiveWindow.DisplayGridlines = False
'ファイル名指定
Application.DisplayAlerts = False
ActiveWorkbook.CheckCompatibility = False
'ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Range("A1") & "【" & tmpRng & "様】.xls", FileFormat:=xlWorkbookNormal, _
Password:="KDDI" & Mypass
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "【" & tmpRng & "様】" & Range("A1") & ".xlsx", FileFormat:=xlWorkbookDefault, _
Password:="KDDI" & Mypass
'ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "（" & tmpRng & "様）" & Range("A1") & ".xls", FileFormat:=xlWorkbookNormal, _
Password:="KDDI" & Mypass
'差異見本選択して閉じる
Range("A1").Select
Application.DisplayAlerts = False
ActiveWorkbook.CheckCompatibility = False
ActiveWorkbook.Save
'ActiveWorkbook.ChangeFileAccess Mode:=xlReadOnly
ActiveWorkbook.Close
Application.DisplayAlerts = True
'元xlsの後片付け
Sheets("設定").Select
Application.DisplayAlerts = False
Worksheets(tmpRng.Value).Delete
Application.DisplayAlerts = True
Next
ThisWorkbook.Activate
Application.Goto motoRng
ActiveSheet.ShowAllData
Application.ScreenUpdating = True
Sheets("設定").Select
MsgBox "11行目ファイル作成終了"
End Sub （masamasa1736） 2023/11/16(木) 13:06:50
該当の箇所 ＜どこ？ データが入っているところ ＜どこ？ の一番下以降 ＜どこ？ と一番右以降の部分 ＜どこ？ を全削除
貴方は分かるかもしれませんが、 読んでる人は分かりませんよ。
あと、セル範囲が名前の定義にしてあるので、 そこも分かりませんね。
表形式でサンプル提示を検討ください。
（tkit） 2023/11/16(木) 13:33:53
（フフフフ） 2023/11/16(木) 19:12:32
＞Set motoRngAll = Range("配信一覧_11行目2") ’配信一覧_11行目2はA列からAS列全体
その列全体と言うのが時間の掛かる原因みたいです。
これに変えてみたらどうですかね？
↓
Set motoRngAll = Range("AS1", Cells(Rows.Count, "A").End(xlUp))
（半平太） 2023/11/16(木) 22:03:41
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.