エクセルマクロ、生物学、生命科学、きのこ、禅

偶然に出会ったものごとについて書いていきます。

ヒトの一生の長さを通して歴史を眺めるマクロ

ヒトに寿命は通常は100年に満たない。この時間の長さを目安に歴史の流れを見てみる年表を作成するマクロです。

まずは、注目する人物の生誕年、没年、業績などを表に記入します。

次に、文字列合体マクロで、年表に記載したい文字列を作ります。

 

 

そして、年表への転記マクロで、別シートに、以下のような年表を描きます。

 

以下は、文字列の合体マクロです。

Sub a_名前業績年代の合体()

Dim i As Integer

Sheets("Scientists").Select

  For i = 3 To 100

       Cells(i, "I").Value = Cells(i, "B").Value & "(" & Cells(i, "C").Value & ")[" & Cells(i, "D").Value & "-" & Cells(i, "E").Value & "]"

  Next i

End Sub

 

 

以下が、年表シートへの転記マクロです。

Sub b_年表への転記()

Dim i As Integer
Dim j As Integer

Sheets("Life_span").Select

For i = 5 To 100

    If Worksheets("Scientists").Cells(i - 2, "D") = "" Then
       Exit For
    End If

   Cells(i, "A").Value = Worksheets("Scientists").Cells(i - 2, "A") ' 番号
   Cells(i, "B").Value = Worksheets("Scientists").Cells(i - 2, "G") '分野
   Cells(i, "C").Value = Worksheets("Scientists").Cells(i - 2, "F") '  国名
   Cells(i, Worksheets("Scientists").Cells(i - 2, "D").Value - 1400 - 48).Value = Worksheets("Scientists").Cells(i - 2, "I")
   
   ' "D"は生年であり、その値(年)から-1448した値の列に、"I" の文字列を記入する。
   
   j = Worksheets("Scientists").Cells(i - 2, "E").Value 'jは没年
   
   If Worksheets("Scientists").Cells(i - 2, "E") = "" Then '没年なし
   
      j = 2022
       
   End If
   
   Range(Cells(i, Worksheets("Scientists").Cells(i - 2, "D").Value - 1400 - 48), Cells(i, j - 1400 - 48)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Next i


End Sub