test

stillalive

Excel関連 †

■転記
転記

2.マクロ_台帳連続記入 †

 Sub ext1()

'-----------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 & "が存在します。削除して再度実行してください。"
               End
           End If
       Next Si2
    Next Si1
'-----------------------------
   
   
 'Sheet1は必須 なかった時の処理を追加した方が良いが現状なし。
 SheetName1 = Worksheets("Sheet1").Name '抽出対象リストが含まれる表があるシート

 '-----------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 & "個です。マクロを開始します。"

  '見出し行の生成
    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"
       
   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
       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 .Cells(i, "A") = wS.Range("B2") And .Cells(i, "B") = wS.Range("C2") Then
   If Worksheets(SheetName1).Cells(i, "C") = Worksheets(sheetName2).Cells(2 + k, "C") And Worksheets(SheetName1).Cells(i, "O") <> "YES" Then
   'sheet2の図番とsheet1の図番が等しい。且つsheet1の図番の未実装オプションありの場合
   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
   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
   'MsgBox "cnt2は" & cnt2
   Dim lastRow5 As Long
   Dim cnt5 As Long
   lastRow5 = Worksheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Row
   
   'MsgBox "sheet4 lastrow5は" & lastRow5

   Worksheets(sheetName3).Select
   
   Range("B" & lastRow2 + 1 & ":B" & cnt2).Select
   'MsgBox "未実装範囲の選択---B" & lastRow2 + 1 & ":B" & cnt2
   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

   'MsgBox "kは" & k
   
   Next k

End With

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 Worksheets("Sheet4").Range("F" & suuryo1).Value = INSUU1

Next suuryo1

Worksheets(SheetName4).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
   Worksheets("Sheet2").Delete
   Worksheets("Sheet3").Delete
   Application.DisplayAlerts = True
   

End Sub