■ページ内リンク
1.マクロ_台帳連続記入_日付
2.マクロ_台帳連続記入_指定文字
3.マクロ_リスト作成_ユニーク抽出_(重複在りの列アイテム群から重複分を削除し、ユニークなアイテムだけでリスト化する)
4.マクロ_オートフィルター
5.マクロ_ラストセーブデイト表示
6.マクロ_outlookメール保存
7.マクロ_部品一覧表作成
8.マクロ_部品一覧表->1品1行表へ変換
台帳エクセルファイルに、キーワード(ここではKeyItem?という変数)が一致する行の指定列に日付(ここではxday)を入れていく作業を自動化したもの。
Sub Macro5() ' Macro5 Macro Workbooks.Open Filename:=ThisWorkbook.Path & "\daityo.xlsx" Windows("データインプット用.xlsm").Activate Worksheets("Sheet1").Activate Dim x As String Dim i As Long For i = 4 To 13 Windows("データインプット用.xlsm").Activate Worksheets("Sheet1").Activate x = Cells(i, 1).Value ' x = Range("A4").Value Dim xday As Date xday = ActiveSheet.Cells(i, 3) ' xday = ActiveSheet.Range("C4") If Cells(i, 1) = "" Then '空白 MsgBox "入力欄が空欄です。値を入力して再度実行願います。" End End If MsgBox x & " の完了日付け " & xday & " を入力します。" Windows("daityo.xlsx").Activate Sheets("Sheet1").Select Worksheets("Sheet1").Activate Dim SearchRange As Range Dim ResultRange As Range Dim KeyItem As String Set SearchRange = Range("C1:C100") '検索したいデータ範囲 ' KeyItem = "P-07588" KeyItem = x Set ResultRange = SearchRange.Find(KeyItem, LookAt:=xlWhole) If ResultRange Is Nothing Then MsgBox "検索文字列はありませんでした" Exit Sub End If MsgBox ResultRange.Row & "行目に見つかりました。" ' Cells(ResultRange.Row, "L").Select '検索一致行の指定列の選択 'Set xday = Date 'Cells(1, "L").Value = xday 'デバッグ用 ' Set ResultRange.Row = Long Dim ResultRange2 ResultRange2 = CInt(ResultRange.Row) Cells(ResultRange2, "L") = xday MsgBox x & " の完了日付け " & xday & " を入力しました。" Next i Windows("データインプット用.xlsm").Activate Worksheets("Sheet1").Activate Workbooks("daityo.xlsx").Close End Sub
Sub file_input1() Dim file1 As String Dim file2 As String Dim files As String file1 = "部品管理" file2 = "新規" strfiles = "file1=" & file1 & ", file2=" & file2 MsgBox strfiles Workbooks(file1 & ".xlsm").Activate Worksheets("Sheet1").Select MsgBox "File= " & file1 & " を開きました" Workbooks.Open Filename:=ThisWorkbook.Path & "\" & file2 & ".xlsx" Workbooks(file2 & ".xlsx").Activate Worksheets("Sheet1").Select MsgBox "File= " & file2 & "の Sheet1 を開きました" 'Workbooks.Open Filename:=ThisWorkbook.Path & "\Book1.xlsx" 'Workbooks.Open Filename:=ThisWorkbook.Path & "\新規.xlsx" Dim k As Long For k = 1 To 4 '入力ファイルを選択 Workbooks("部品管理.xlsm").Activate Worksheets("Sheet1").Select Dim s As String 's = Range("B2").Value s = Cells(1 + k, 2).Value MsgBox s Dim SrhRng As Range Dim Key As String Key = s '転送先ファイルを選択 Workbooks(file2 & ".xlsx").Activate Worksheets("Sheet1").Select 'BJ列(62列)には図番が入力されている。BU列(73列)には日付けを入力する。 'Set SrhRng = Columns(62).Find(s) Set SrhRng = Columns(62).Find(s, , xlValues, xlWhole) ' Debug.Print SrhRng.Address & "には" & SrhRng.Value & "と入力されています。" 'SR = SrhRng.Value ' MsgBox SrhRng If SrhRng Is Nothing Then MsgBox "'" & Key & "'はありませんでした" Else MsgBox "'" & Key & "'は" & SrhRng.Row & "行目にあります" Dim i As String Dim l As String Dim inputcell As String Dim inputcolumn As String 'l = Selection.Row i = SrhRng.Row l = SrhRng.Column ' l = SrhRng.Address inputcolumn = l + 11 'inputcell = Range(l).Cells(1, 12).Address 'Cells(行row、列column) MsgBox "選択セルは" & inputcolumn & "列目にあります" 'SrhRng.Select 'If Cells(i, inputcolumn) = "" Then If Cells(i, 73) = "" Then MsgBox "セルは空白です" Debug.Print (s) 'MsgBox Format(Date, "yyyy/mm/dd") 'Range().Value = Date Cells(i, 73).Activate Cells(i, 73) = DateValue(Now) Dim chkcell As String chkcell = ActiveCell.Address MsgBox chkcell & "に" & Format(Date, "yyyy/mm/dd") & "を入力しました。" Else MsgBox "セルには入力データがすでにありますのでPASSします。" End If End If Next k 'Application.DisplayAlerts = False 'Workbooks(file2 & ".xlsx").Close 'Application.DisplayAlerts = True End Sub
Sub filter2() Sheets("Sheet1").Select Dim A As String A = Cells(3, 5) Sheets("Sheet2").Select ' Selection.AutoFilter 'Range("A1").AutoFilter Field:=5, Range("E2").NumberFormatLocal) ActiveSheet.Range("A9").AutoFilter Field:=5, Criteria1:=A Sheets("Sheet2").Range("A10").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet1").Select Sheets("Sheet1").Range("A10").PasteSpecial _ Paste:=xlPasteValues ' Range("A9").CurrentRegion.Copy Sheets("Sheet1").Range("A10") Debug.Print A End Sub
Sub taisyobuhintyuusyutu1() sheetName1 = Worksheets("Sheet1").Name '抽出対象リストが含まれる表があるシート sheetName2 = Worksheets("Sheet2").Name '抽出後のリストを貼り付けるシート Worksheets(sheetName1).Select '抽出対象リストがある表のシートを選択 Dim MaxRow As Long MaxRow = Cells(Rows.Count, 1).End(xlUp).Row 'データ最後尾の行を取得。ここでは1列目(A列)のデータ有無で判定している。 Worksheets(sheetName1).Select 'sheet1を選択 重複部品を削除し、対象部品リストを作成する。 Range(Cells(1, 4), Cells(MaxRow, 4)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets(sheetName2).Range("A1"), Unique:=True '重複チェックを4列目のアイテムで行い、重複分を削除してリスト化。Sheet2へ出力 End Sub
最後にセーブした時間を表示する。下記をmoduleに記述。
Public Function LastSaveTime() As Variant Application.Volatile LastSaveTime = ThisWorkbook.BuiltinDocumentProperties("Last save time").Value End Function
任意の表示させたいセルを選び、下記を入力する。書式表示を日付に変更。
=LastSaveTime()
homepageファイルをindex.htmlとして下記内容を入力する。
データファイルsaiban1.htm(リンク先)はエクセルなどからhtmlへ変換する。
'Dim myStgCount As StorageItem ' 'メール受信時に発生するイベント 'Private Sub Application_NewMailEx(ByVal EntryIDCollection As String) ' Dim i As Integer ' Dim c As Integer ' Dim colID As Variant ' ' If InStr(EntryIDCollection, ",") = 0 Then ' SaveAttachments EntryIDCollection ' Else ' colID = Split(EntryIDCollection, ",") ' For i = LBound(colID) To UBound(colID) ' SaveAttachments colID(i) ' Next ' End If ' End Sub ' ' 添付ファイルの保存を行うサブ プロシージャ 'Private Sub SaveAttachments(ByVal strEntryID As String) ' Const SAVE_PATH = "C:\Users\ak001277\Desktop\WORK\temp\" ' Dim objFSO As Object ' FileSystemObject ' Dim objMsg As Object ' Dim objAttach As Attachment ' Dim strFileName As String ' Dim c As Integer: c = 1 ' ' Set objFSO = CreateObject("Scripting.FileSystemObject") ' Set objMsg = Application.Session.GetItemFromID(strEntryID) ' ' ここで条件指定 ' ' For Each objAttach In objMsg.Attachments ' With objAttach ' ' strFileName = SAVE_PATH & objAttach.FileName ' ' While objFSO.FileExists(strFileName) ' strFileName = SAVE_PATH & Left(.FileName, InStrRev(.FileName, ".") - 1) _ ' & "-" & c & Mid(.FileName, InStrRev(.FileName, ".")) ' c = c + 1 ' Wend ' ' .SaveAsFile strFileName ' End With ' Next ' Set objMsg = Nothing ' Set objFSO = Nothing ' End Sub
Sub txt1() sheetName1 = Worksheets("Sheet1").Name '抽出対象リストが含まれる表があるシート sheetName2 = Worksheets("Sheet2").Name '抽出後のリストを貼り付けるシート sheetName3 = Worksheets("Sheet3").Name Worksheets(sheetName1).Select '抽出対象リストがある表のシートを選択 Dim MaxRow As Long MaxRow = Cells(Rows.Count, 1).End(xlUp).Row 'データ最後尾の行を取得。ここでは1列目(A列)のデータ有無で判定している。 Worksheets(sheetName1).Select 'sheet1を選択 重複部品を削除し、対象部品リストを作成する。 Range(Cells(1, 3), Cells(MaxRow, 3)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets(sheetName2).Range("A1"), Unique:=True '重複チェックを4列目のアイテムで行い、重複分を削除してリスト化。Sheet2へ出力 Dim i As Long, lastRow As Long Dim cnt As Long, wS As Worksheet Set wS = Worksheets("Sheet3") lastRow = wS.Cells(Rows.Count, "B").End(xlUp).Row If lastRow > 3 Then Range(wS.Cells(6, "B"), wS.Cells(lastRow, "E")).ClearContents End If cnt = 1 With Worksheets("Sheet1") For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row 'If .Cells(i, "A") = wS.Range("B2") And .Cells(i, "B") = wS.Range("C2") Then If .Cells(i, "C") = Worksheets(sheetName2).Range("A2") And .Cells(i, "E") = Worksheets(sheetName2).Range("E2") Then cnt = cnt + 1 wS.Cells(cnt, "A").Resize(, 4).Value = .Cells(i, "A").Resize(, 4).Value wS.Cells(cnt, "B").Resize(, 4).Value = .Cells(i, "B").Resize(, 4).Value wS.Cells(cnt, "C").Resize(, 4).Value = .Cells(i, "C").Resize(, 4).Value wS.Cells(cnt, "D").Resize(, 4).Value = .Cells(i, "D").Resize(, 4).Value wS.Cells(cnt, "E").Resize(, 4).Value = .Cells(i, "E").Resize(, 4).Value End If Next i Dim j As Long, lastRow2 As Long Dim cnt2 As Long lastRow2 = wS.Cells(Rows.Count, "A").End(xlUp).Row cnt2 = lastRow2 MsgBox cnt2 For j = 2 To .Cells(Rows.Count, "A").End(xlUp).Row If .Cells(j, "C") = Worksheets(sheetName2).Range("A2") And .Cells(j, "E") = "" Then cnt2 = cnt2 + 1 wS.Cells(cnt2, "A").Resize(, 4).Value = .Cells(j, "A").Resize(, 4).Value wS.Cells(cnt2, "B").Resize(, 4).Value = .Cells(j, "B").Resize(, 4).Value wS.Cells(cnt2, "C").Resize(, 4).Value = .Cells(j, "C").Resize(, 4).Value wS.Cells(cnt2, "D").Resize(, 4).Value = .Cells(j, "D").Resize(, 4).Value wS.Cells(cnt2, "E").Resize(, 4).Value = .Cells(j, "E").Resize(, 4).Value End If Next j End With End Sub
回路図CAD等から1品1行の部品表が出力されるとき、これを、同一部品ごとにまとめるマクロ。
ここでは、未実装のフラグとしてo列に"YES"を与えられたとき、部品毎、実装未実装毎、をそれぞれまとめるマクロです。
下表7-1を表7-2の様にまとめることができます。
準備として、sheet1にこのマクロを記述します。またsheet1に表7-1のデータを張り付けます。他にシートがあってはいけません。
このマクロを実装すると、sheet4に表7-2が生成されます。
表7-1.部品表(1品1行)
A | B | C | D | E | F | G | H | I | J | K | L | M | N | O |
No | 記号 | 図番 | 品名 | メーカー | 使用可可否 | 温度上限 | 温度下限 | サイズ | リフロー | フロー | 面実装 | 分類 | 定数 | 未実装 |
C1 | xxx111222 | GR442QR73D102KW01L | 株式会社村田製作所 | 使用可 | 125℃ | -55℃ | 4520 | ○ | × | Y | 積層セラミックコンデンサ | 1000pF | ||
C2 | xxx111333 | GRM21BB31C106KE15L | 株式会社村田製作所 | 使用可 | 85℃ | -25℃ | 2012 | ○ | ○ | Y | 積層セラミックコンデンサ | 10uF | ||
C3 | xxx111222 | GR442QR73D102KW01L | 株式会社村田製作所 | 使用可 | 125℃ | -55℃ | 4520 | ○ | × | Y | 積層セラミックコンデンサ | 1000pF | YES | |
C4 | xxx111333 | GRM21BB31C106KE15L | 株式会社村田製作所 | 使用可 | 85℃ | -25℃ | 2012 | ○ | ○ | Y | 積層セラミックコンデンサ | 10uF | ||
C5 | xxx111444 | GRM155R71H104KE14D | 株式会社村田製作所 | 新規設計使用禁止 | 125℃ | -55℃ | 1005 | ○ | × | Y | 積層セラミックコンデンサ | 0.1uF | ||
C6 | xxx111444 | GRM155R71H104KE14D | 株式会社村田製作所 | 新規設計使用禁止 | 125℃ | -55℃ | 1005 | ○ | × | Y | 積層セラミックコンデンサ | 0.1uF | YES | |
C7 | xxx111444 | GRM155R71H104KE14D | 株式会社村田製作所 | 新規設計使用禁止 | 125℃ | -55℃ | 1005 | ○ | × | Y | 積層セラミックコンデンサ | 0.1uF | ||
C8 | xxx111446 | GRM033Z71C104KE14D | 株式会社村田製作所 | 使用可 | 125℃ | -55℃ | 603 | ○ | × | Y | 積層セラミックコンデンサ | 0.1uF | ||
C9 | xxx111999 | GRM188Z71C475KE21D | 株式会社村田製作所 | 使用可 | 125℃ | -55℃ | 1608 | ○ | ○ | Y | 積層セラミックコンデンサ | 4.7uF |
表7-2.部品表一覧 部品毎、実装未実装毎
A | B | C | D | E | F |
記号 | 図番 | 品名 | メーカー | 未実装 | Qty |
C1 | xxx111222 | GR442QR73D102KW01L | 株式会社村田製作所 | 1 | |
C3 | xxx111222 | GR442QR73D102KW01L | 株式会社村田製作所 | YES | 1 |
C2,C4 | xxx111333 | GRM21BB31C106KE15L | 株式会社村田製作所 | 2 | |
C5,C7 | xxx111444 | GRM155R71H104KE14D | 株式会社村田製作所 | 2 | |
C6 | xxx111444 | GRM155R71H104KE14D | 株式会社村田製作所 | YES | 1 |
C8 | xxx111446 | GRM033Z71C104KE14D | 株式会社村田製作所 | 1 | |
C9 | xxx111999 | GRM188Z71C475KE21D | 株式会社村田製作所 | 1 |
・マクロ
Sub combined() sheetName1 = Worksheets("Sheet1").Name '-----------Sheet2,Sheet3,Sheet4 が存在すると強制終了させる------------------ Dim Si1 As Integer Dim Si2 As Integer Dim Sname1 As String Dim Sname2 As String For Si1 = 2 To 4 For Si2 = 2 To Worksheets.Count Sname2 = Worksheets(Si2).Name Sname1 = "sheet" & Si1 If Sname1 = Sname2 Then MsgBox "シート:" & Sname1 & "が存在します。" & vbCrLf & "削除して再度実行してください。" End End If Next Si2 Next Si1 '----------------------------- '-----------Sheet2,Sheet3,Sheet4 を作成する。------------------ Dim SC As Integer For SC = 2 To 4 Dim existSh As Worksheet Set existSh = ThisWorkbook.Worksheets(sheetName1) '後ろ(右側)に新しいシートを作成する Worksheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = "sheet" & SC Next SC '----------------------------- sheetName2 = Worksheets("Sheet2").Name '抽出後のリストを貼り付けるシート ユニークな部品リストの生成 マクロ終了時に削除 sheetName3 = Worksheets("Sheet3").Name '実装、未実装を振り分けて整列させるシート マクロ終了時に削除 sheetName4 = Worksheets("Sheet4").Name '1部品1行で実装非実装を分けて表示 最終的なOutputを記述するシート Worksheets(sheetName2).Range("A2:X999").Clear Worksheets(sheetName3).Range("A2:X9999").Clear Worksheets(sheetName4).Range("A2:X9999").Clear Worksheets(sheetName1).Select '抽出対象リストがある表のシートを選択 Dim MaxRow As Long MaxRow = Cells(Rows.Count, 2).End(xlUp).Row 'データ最後尾の行を取得。ここでは2列目(B列)のデータ有無で判定している。 If MaxRow > 2000 Then MsgBox "ITEM総数は" & MaxRow & "です。2001個以上の場合は保証できませんので終了します。" End End If Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim MaxUItem As Long '抽出対象の入ったシートと、抽出後のデータを格納するシートを指定 Set Sh1 = Sheets("Sheet1") Set Sh2 = Sheets("Sheet2") 'Sh1から重複部品を削除し、Sh2へユニークな対象部品リストを作成する。 ' Sh1.Range(Cells(1, 3), Cells(MaxRow, 3)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sh2.Range("A1"), Unique:=True Sh1.Range(Cells(1, 3), Cells(MaxRow, 3)).AdvancedFilter Action:=xlFilterInPlace, Unique:=True Sh1.Range("A1").CurrentRegion.Copy Sh2.Range("A1") If ActiveSheet.FilterMode = True Then 'フィルタ解除 ActiveSheet.ShowAllData End If With Worksheets("Sheet1") Worksheets(sheetName2).Select MaxUItem = Cells(Rows.Count, 2).End(xlUp).Row 'ユニークなアイテム数を取得 ' MsgBox "ITEMは" & MaxUItem - 1 & "個です。マクロを開始します。" '見出し行の生成(最終的なOutputシートである、sheet4の部品表の見出し行を生成します。) Worksheets(sheetName4).Range("A" & 1).Value = Worksheets(sheetName2).Range("B" & 1).Value Worksheets(sheetName4).Range("B" & 1).Value = Worksheets(sheetName2).Range("C" & 1).Value Worksheets(sheetName4).Range("C" & 1).Value = Worksheets(sheetName2).Range("D" & 1).Value Worksheets(sheetName4).Range("D" & 1).Value = Worksheets(sheetName2).Range("E" & 1).Value Worksheets(sheetName4).Range("E" & 1).Value = Worksheets(sheetName2).Range("O" & 1).Value Worksheets(sheetName4).Range("F" & 1).Value = "Qty" 'sheet2で生成したユニークな部品数の数"MaxUItem"だけ繰り返す処理を始めます。 Dim k As Long For k = 0 To MaxUItem Dim i As Long, lastRow As Long Dim cnt As Long, wS As Worksheet Set wS = Worksheets("Sheet3") lastRow = wS.Cells(Rows.Count, "B").End(xlUp).Row 'sheet3の作業最終行の取得 If lastRow < 1 Then lastRow = 1 'Range(wS.Cells(2, "A"), wS.Cells(lastRow, "E")).ClearContents End If cnt = lastRow 'MsgBox "cntは" & cnt For i = 2 To Worksheets(sheetName1).Cells(Rows.Count, "B").End(xlUp).Row If Worksheets(sheetName1).Cells(i, "C") = Worksheets(sheetName2).Cells(2 + k, "C") And Worksheets(sheetName1).Cells(i, "O") <> "YES" Then 'sheet2のユニークな図番とsheet1の図番が等しく、且つsheet1の図番の未実装オプションが("YES")ではない行を全て抽出し、Sheet3に記述します。 cnt = cnt + 1 wS.Cells(cnt, "A").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "A").Resize(, 4).Value wS.Cells(cnt, "B").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "B").Resize(, 4).Value wS.Cells(cnt, "C").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "C").Resize(, 4).Value wS.Cells(cnt, "D").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "D").Resize(, 4).Value wS.Cells(cnt, "E").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "E").Resize(, 4).Value 'wS.Cells(cnt, "F").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "F").Resize(, 4).Value 'wS.Cells(cnt, "G").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "G").Resize(, 4).Value 'wS.Cells(cnt, "H").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "H").Resize(, 4).Value 'wS.Cells(cnt, "I").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "I").Resize(, 4).Value 'wS.Cells(cnt, "J").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "J").Resize(, 4).Value 'wS.Cells(cnt, "K").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "K").Resize(, 4).Value 'wS.Cells(cnt, "L").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "L").Resize(, 4).Value 'wS.Cells(cnt, "M").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "M").Resize(, 4).Value 'wS.Cells(cnt, "N").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "N").Resize(, 4).Value 'wS.Cells(cnt, "O").Resize(, 4).Value = Worksheets(sheetName1).Cells(i, "O").Resize(, 4).Value wS.Cells(cnt, "O").Resize(, 4).Value = "" End If Next i If cnt > lastRow Then '抽出したアイテムの記号をまとめて一つのセル内に記述します。 Dim lastRow4 As Long Dim cnt4 As Long lastRow4 = Worksheets("Sheet4").Cells(Rows.Count, 2).End(xlUp).Row If lastRow4 < 1 Then lastRow4 = 1 End If Worksheets(sheetName3).Select Range("B" & lastRow & ":B" & cnt).Select 'MsgBox "B" & lastRow & ":B" & cnt Dim conb As String Dim conbrange As Range conlec = "" For Each conbrange In Range("B" & lastRow + 1 & ":B" & cnt) conlec = conlec & conbrange.Text & "," Next conbrange conlec = Left(conlec, Len(conlec) - 1) Worksheets(sheetName4).Range("A" & lastRow4 + 1).Value = conlec 'k+1から変える Worksheets(sheetName4).Range("B" & lastRow4 + 1).Value = Range("C" & cnt).Value Worksheets(sheetName4).Range("C" & lastRow4 + 1).Value = Range("D" & cnt).Value Worksheets(sheetName4).Range("D" & lastRow4 + 1).Value = Range("E" & cnt).Value Worksheets(sheetName4).Range("E" & lastRow4 + 1).Value = Range("O" & cnt).Value Worksheets(sheetName4).Select End If Dim j As Long, lastRow2 As Long Dim l As Long Dim cnt2 As Long lastRow2 = wS.Cells(Rows.Count, "B").End(xlUp).Row cnt2 = lastRow2 For j = 2 To Worksheets(sheetName1).Cells(Rows.Count, "B").End(xlUp).Row If Worksheets(sheetName1).Cells(j, "C") = Worksheets(sheetName2).Cells(2 + k, "C") And .Cells(j, "O") = "YES" Then 'sheet2のユニークな図番とsheet1の図番が等しく、且つsheet1の図番の未実装オプションが("YES")である行を全て抽出し、Sheet3に記述します。 cnt2 = cnt2 + 1 wS.Cells(cnt2, "A").Resize(, 4).Value = .Cells(j, "A").Resize(, 4).Value wS.Cells(cnt2, "B").Resize(, 4).Value = .Cells(j, "B").Resize(, 4).Value wS.Cells(cnt2, "C").Resize(, 4).Value = .Cells(j, "C").Resize(, 4).Value wS.Cells(cnt2, "D").Resize(, 4).Value = .Cells(j, "D").Resize(, 4).Value wS.Cells(cnt2, "E").Resize(, 4).Value = .Cells(j, "E").Resize(, 4).Value 'wS.Cells(cnt2, "F").Resize(, 4).Value = .Cells(j, "F").Resize(, 4).Value 'wS.Cells(cnt2, "G").Resize(, 4).Value = .Cells(j, "G").Resize(, 4).Value 'wS.Cells(cnt2, "H").Resize(, 4).Value = .Cells(j, "H").Resize(, 4).Value 'wS.Cells(cnt2, "I").Resize(, 4).Value = .Cells(j, "I").Resize(, 4).Value 'wS.Cells(cnt2, "J").Resize(, 4).Value = .Cells(j, "J").Resize(, 4).Value 'wS.Cells(cnt2, "K").Resize(, 4).Value = .Cells(j, "K").Resize(, 4).Value 'wS.Cells(cnt2, "L").Resize(, 4).Value = .Cells(j, "L").Resize(, 4).Value 'wS.Cells(cnt2, "M").Resize(, 4).Value = .Cells(j, "M").Resize(, 4).Value 'wS.Cells(cnt2, "N").Resize(, 4).Value = .Cells(j, "N").Resize(, 4).Value wS.Cells(cnt2, "O").Resize(, 4).Value = .Cells(j, "O").Resize(, 4).Value End If Next j If cnt2 > lastRow2 Then '抽出したアイテムの記号をまとめて一つのセル内に記述します。 Dim lastRow5 As Long Dim cnt5 As Long lastRow5 = Worksheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Row Worksheets(sheetName3).Select Range("B" & lastRow2 + 1 & ":B" & cnt2).Select Dim conb2 As String Dim conbrange2 As Range conlec2 = "" For Each conbrange2 In Range("B" & lastRow2 + 1 & ":B" & cnt2) conlec2 = conlec2 & conbrange2.Text & "," Next conbrange2 conlec2 = Left(conlec2, Len(conlec2) - 1) Worksheets(sheetName4).Range("A" & lastRow5 + 1).Value = conlec2 Worksheets(sheetName4).Range("B" & lastRow5 + 1).Value = Range("C" & cnt2).Value Worksheets(sheetName4).Range("C" & lastRow5 + 1).Value = Range("D" & cnt2).Value Worksheets(sheetName4).Range("D" & lastRow5 + 1).Value = Range("E" & cnt2).Value Worksheets(sheetName4).Range("E" & lastRow5 + 1).Value = Range("O" & cnt2).Value l = Worksheets(sheetName3).Cells(Rows.Count, "A").End(xlUp).Row End If Next k End With '員数の計算をして記述します。 Worksheets(sheetName4).Select Dim INSUU1 As Integer Dim lastRow6 As Long lastRow6 = Worksheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Row Dim suuryo1 As Integer For suuryo1 = 2 To lastRow6 INSUU1 = Len(Range("A" & suuryo1).Value) - Len(WorksheetFunction.Substitute(Range("A" & suuryo1), ",", "")) + 1 '例えばC1,C2,C3の場合、","を""に置き換えたC1C2C3とのバイト数との差が3Byteなので、員数3となる計算をしています。 Worksheets("Sheet4").Range("F" & suuryo1).Value = INSUU1 Next suuryo1 '不要シートの削除、Output sheetのsheet4の体裁を整えています。 Columns("A").ColumnWidth = 35 Columns("A").Font.Size = 9 Range("A" & 1).Font.Size = 11 Range("A1:F1").HorizontalAlignment = xlCenter Range("B2:E" & lastRow6).HorizontalAlignment = xlLeft Range("F2:F" & lastRow6).HorizontalAlignment = xlCenter Columns("B:E").AutoFit Range("A2:A" & lastRow6).WrapText = True Application.DisplayAlerts = False Worksheets("Sheet2").Delete Worksheets("Sheet3").Delete Application.DisplayAlerts = True ActiveWindow.Zoom = 80 End Sub
項目7.のマクロで一覧表としたものを、元の1品1行の表へ戻すマクロです。
項目7の表7-2から、表7-1を生成します。
項目7.で生成されたsheet4が存在し、各Itemの列順が同じである必要があります。
・マクロ
Sub Extract() Dim Si1 As Integer Dim Si2 As Integer Dim Sname1 As String Dim Sname2 As String For Si1 = 5 To 5 For Si2 = 2 To Worksheets.Count Sname2 = Worksheets(Si2).Name Sname1 = "sheet" & Si1 If Sname1 = Sname2 Then MsgBox "シート:" & Sname1 & "が存在します。" & vbCrLf & "" Application.DisplayAlerts = False Worksheets("sheet5").Select ActiveSheet.Delete Application.DisplayAlerts = True End If Next Si2 Next Si1 sheetName4 = Worksheets("Sheet4").Name Worksheets(sheetName4).Select 'Worksheets(sheetName4).Range("F2:ZZ9999").Clear Dim SC As Integer For SC = 5 To 5 Dim existSh As Worksheet Set existSh = ThisWorkbook.Worksheets(sheetName4) '後ろ(右側)に新しいシートを作成する Worksheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = "sheet" & SC Next SC sheetName5 = Worksheets("Sheet5").Name Dim lastRow6 As Long lastRow6 = Worksheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Row ' MsgBox lastRow6 Dim Number1 As Integer For k = 2 To lastRow6 Dim myRng As Range Set myRng = Worksheets(sheetName4).Cells(k, 1) Application.DisplayAlerts = False 'TextToColumnsメソッドは、指定セルのデータを指定区切り文字で区切ります。 myRng.TextToColumns _ Destination:=Cells(k, 8), _ DataType:=xlDelimited, _ Comma:=True Application.DisplayAlerts = True Next k Dim cnt1 As Long cnt1 = 0 Worksheets(sheetName5).Cells(1, 1).Value = Worksheets(sheetName4).Cells(1, 1).Value Worksheets(sheetName5).Cells(1, 2).Value = Worksheets(sheetName4).Cells(1, 2).Value Worksheets(sheetName5).Cells(1, 3).Value = Worksheets(sheetName4).Cells(1, 3).Value Worksheets(sheetName5).Cells(1, 4).Value = Worksheets(sheetName4).Cells(1, 4).Value Worksheets(sheetName5).Cells(1, 5).Value = Worksheets(sheetName4).Cells(1, 5).Value For i = 2 To lastRow6 ' For i = 2 To 3 Number1 = Worksheets(sheetName4).Cells(i, 6).Value ' MsgBox "Number1=" & Number1 & ",i=" & i For j = 8 To 8 + Number1 - 1 Worksheets(sheetName5).Cells(j - 6 + cnt1, 1).Value = Worksheets(sheetName4).Cells(i, j).Value Worksheets(sheetName5).Cells(j - 6 + cnt1, 2).Value = Worksheets(sheetName4).Cells(i, 2).Value Worksheets(sheetName5).Cells(j - 6 + cnt1, 3).Value = Worksheets(sheetName4).Cells(i, 3).Value Worksheets(sheetName5).Cells(j - 6 + cnt1, 4).Value = Worksheets(sheetName4).Cells(i, 4).Value Worksheets(sheetName5).Cells(j - 6 + cnt1, 5).Value = Worksheets(sheetName4).Cells(i, 5).Value Next j cnt1 = cnt1 + Number1 Next i Dim lastRow7 As Long lastRow7 = Worksheets("Sheet5").Cells(Rows.Count, 1).End(xlUp).Row Dim result2 As String For m = 2 To lastRow7 Call FindNumberRegExp2(Worksheets(sheetName5).Cells(m, 1).Value, result) Worksheets(sheetName5).Cells(m, 7).Value = result Next m Worksheets(sheetName5).Select With ActiveSheet .Sort.SortFields.Clear .Sort.SortFields.Add _ Key:=ActiveSheet.Cells(2, 2), _ SortOn:=xlSortOnValues, _ Order:=xlAscending, _ DataOption:=xlSortNormal .Sort.SortFields.Add _ Key:=ActiveSheet.Cells(2, 7), _ SortOn:=xlSortOnValues, _ Order:=xlAscending, _ DataOption:=xlSortNormal With .Sort .SetRange Range(Cells(2, 1), Cells(lastRow7, 7)) .Header = xlNo 'title にしない .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With Worksheets(sheetName5).Select 'Columns("A").ColumnWidth = 35 'Columns("A").Font.Size = 9 Range("A" & 1).Font.Size = 11 Range("A1:E1").HorizontalAlignment = xlCenter Range("B2:E2001").HorizontalAlignment = xlLeft Columns("B:E").AutoFit Range("A2:A2001").WrapText = True Application.DisplayAlerts = False Application.DisplayAlerts = True ActiveWindow.Zoom = 80 End Sub