自分用マクロ。

Option VBASupport 1
REM  *****  BASIC  *****

   Dim wb As Workbook
   Dim wsOrig As Worksheet
   Dim wsIN as worksheet
   Dim wsOUT as worksheet
   Dim wsHokensya as worksheet
   
   
Sub Main
   
   Set wb = ThisWorkbook
   Set wsOrig = wb.Worksheets("原本")
   Set wsIN=wb.Worksheets("IN")
   Set wsOUT=wb.Worksheets("OUT")
   set wsHokensya = wb.Worksheets("保険者")


   
   Dim cnt1 as Long
   cnt1 = wsIN.Cells(Rows.Count, "A").End(xlUp).Row
   Call B(wsIN, cnt1)
   

   Dim cnt2 as Long
   cnt2 = wsOUT.Cells(Rows.Count, "A").End(xlUp).Row
   Call B(wsOUT,cnt2)	
   
End Sub


Sub B(wsInOut As Worksheet, cnt As Long)
   ' 変数の宣言
   Dim pref_ As String
   Dim day_ As Date
   Dim name_ As String
   Dim birth_ As Date
   Dim sex_ As String
   Dim rng_ As Range
   Dim bangou_ As Long
   
   Dim shp As Shape
   Dim ws As Worksheet
   
   Dim listRange As Range
   Set listRange = wsInOut.Range("I1:I5")
   Dim index As Integer
   Dim slctValue As Variant
   Dim number As Range

 
 
   For i = 2 To cnt
      pref_ = wsInOut.Cells(i, 5)
      day_ = wsInOut.Cells(i, 1).Value
      name_ = wsInOut.Cells(i, 2).Value
      birth_ = wsInOut.Cells(i, 4).Value
      sex_ = wsInOut.Cells(i, 3).Value
      
      wsOrig.Copy
      ActiveWorkbook.SaveAs Filename:=wb.Path & "\" & wsInOut.Name & " " & Format(day_, "m月d日") & name_ & ".xlsx"
      Set ws = ActiveWorkbook.Worksheets("原本")
      
      ws.Range("C5") = pref_
      ws.Range("L11") = day_
      ws.Range("D14") = name_
      ws.Range("P13") = birth_
      
      ' 入退所に◯
      If wsInOut.Name = "IN" Then
            Set rng_ = ws.Range("E7")
      Else
            Set rng_ = ws.Range("E9")
      End If
      Set shp = ws.Shapes.AddShape(msoShapeOval, rng_.Left, rng_.Top, rng_.Width, rng_.Height)
      shp.Fill.Transparency = 1
      
      ' 性別に丸
      If sex_ = "男" Then
            Set rng_ = ws.Range("P14")
      Else
            Set rng_ = ws.Range("S14")
      End If
      Set shp = ws.Shapes.AddShape(msoShapeOval, rng_.Left, rng_.Top, rng_.Width, rng_.Height)
      shp.Fill.Transparency = 1
      
      ' 保険者検索
      Set rng_ = wsHokensya.Columns("A").Find(what:=wsInOut.Cells(i, 5).Value, LookIn:=xlValues, LookAt:=xlWhole)
      If Not rng_ Is Nothing Then
            bangou_ = wsHokensya.Cells(rng_.Row, 2).Value
            ws.Range("X25").Value = bangou_
      End If
      
      ' 被保険者番号
      bangou_ = wsInOut.Cells(i, 6).Value
      ws.Cells(2, 18).Value = bangou_
      
      ' 理由
      slctValue = wsInOut.Cells(i, 7).Value
      index = 0
      For Each cell In listRange
            If cell.Value = slctValue Then
               Exit For
            End If
            index = index + 1
      Next cell
      
      If wsInOut.Name = "IN" Then
            If index = 0 Then
               Set number = ws.Range("D15")
            ElseIf index = 1 Then
               Set number = ws.Range("D16")
               ws.Range("O16") = wsInOut.Cells(i, 8).Value
            ElseIf index = 2 Then
               Set number = ws.Range("D17")
               ws.Range("N17") = wsInOut.Cells(i, 8).Value
            Else 
               Set number = ws.Range("D18")
            End If
      Else
            If index = 0 Then
               Set number = ws.Range("D19")
            ElseIf index = 1 Then
               Set number = ws.Range("D20")
               ws.Range("O20") = wsInOut.Cells(i, 8).Value
            ElseIf index = 2 Then
               Set number = ws.Range("D21")
               ws.Range("N17") = wsInOut.Cells(i, 8).Value
            ElseIf index = 3 Then
               Set number = ws.Range("D22")
               ws.Range("M22") = wsInOut.Cells(i, 8).Value
            Else
               Set number = ws.Range("D23")
               ws.Range("I23") = wsInOut.Cells(i, 8).Value
            End If
      End If
      
      Set shp = ws.Shapes.AddShape(msoShapeOval, number.Left, number.Top, number.Width, number.Height)
      shp.Fill.Transparency = 1
      
      ActiveWorkbook.Save
      ActiveWorkbook.Close
   Next i
End Sub