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

Researchmapというサイトに、研究者は様々な研究業績を登録することができる。研究者は、いろいろな場面で、研究業績を報告しなければならない。Researchmapに登録している情報を利用して、報告書を仕上げることができれば、報告書作成の手間が省ける。各研究機関で、Researchmap情報を活用でいるようにそれぞれで工夫はしているようだ。

Researchmapからは、自分の登録情報を、csvファイルやjsonファイルで、ダウンロードできる。このcsvファイル群から、必要な情報を抜き出して、Wordで作られた報告書の様式に、自動で転記するマクロを作成した。

１）まず、Researchmapから、csvファイルとして、情報をダウンロードする。

　　このとき日付の名前でzipホルダーでダウンロードされてくるので、同じ名前の通常のホルダーに中身を移す。

２）このホルダー内に、「rm情報転記マクロ」のファイルを入れる。

３）「rm情報転記マクロ」のファイルでは、「csv_data」シートに一時的にデータを読み込み、「rm情報収集」シートに必要な情報を記入して行く。

そのマクロが「rm情報取集マクロ」

:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Sub A_csv_dataへの情報収集()
'
'Researchmapからエクスポートされたファイル群から情報を収集し加工します。

Dim Csv_Import_File 'Excelファイルに取り込むCSVファイルの名前を入れ込む変数'

Dim myDate As Long
Dim myMsg As String
Dim myTitle As String
Dim a As String
Dim b As String

Dim wb As Workbook

Dim str As String, Str1 As String, Str2 As String, Str3 As String, Str4 As String

myTitle = "Researchmap からダウンロードした日付-----------------------------"
myMsg = "日付を20230114のように入力してください。"
myDate = Application.InputBox(Prompt:=myMsg, Title:=myTitle, Default:=1, Type:=1)
If myDate <> 0 Then
a = myDate
Else
MsgBox " 入力された日付が正しくありません。"
End If

' 1)● -----------------【個人情報】 (rm_resarchers)データの取込ーーーー

Csv_Import_File = "rm_researchers" & a & ".csv" '----日付入りのcsvファイル-------どのcsvファイルを開くのか、を決めている。
If Csv_Import_File = "False" Then Exit Sub 'キャンセルなら終了'
b = ThisWorkbook.path & "/" & Csv_Import_File '------- バス付きのファイル名

Worksheets("csv_data").Activate ' csv_dataのシートをアクティブにする'

ThisWorkbook.Sheets("csv_data").Range("A1:ZZ100000").ClearContents '「csv_dataシートのセル「A1?ZZ100000」をクリアする'

Set wb = Workbooks.Open(b)
Sheets(1).Cells.Copy ThisWorkbook.Sheets("csv_data").Range("A1") '全てのデータをこのブックの「csv_data」にコピーして、閉じます。
wb.Close savechanges:=False

str = Cells(3, "R").Value '姓(日本語)
Str1 = Cells(3, "U").Value '名(日本語)
Str2 = Cells(3, "AI").Value '所属名(日本語)
Str3 = Cells(3, "AK").Value '部署名(日本語)
Str4 = Cells(3, "AM").Value '職名(日本語)

Cells(3, 80).Value = str & " " & Str1 '氏名（姓+名）
Cells(3, 90).Value = Str2 & " " & Str3 '所属部署
Cells(3, 100).Value = Str4 & "・" & Cells(3, 80) '職・氏名

With Worksheets("csv_data")
.Range(.Cells(1, 1), .Cells(3, 100)).Copy
End With

With Worksheets("rm情報収集") '「個人情報」は3行目にペーストする。
.Range(.Cells(3, "E"), .Cells(3, "E")).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With

Sheets("rm情報収集").Activate

' 2)● ---------------- (rm_education ）学歴データの取込ーーーー

Csv_Import_File = "rm_education" & a & ".csv" '----日付入りのcsvファイル
If Csv_Import_File = "False" Then Exit Sub 'キャンセルなら終了'
b = ThisWorkbook.path & "/" & Csv_Import_File '------- バス付きのファイル名


Cells(2, "A").Value = a & str & Str1 'データ日付+氏名

Worksheets("csv_data").Activate ' csv_dataのシートをアクティブにする'

' 3)● ---------------- rm_research_experience 職歴、研究歴データの取込ーーーー

Csv_Import_File = "rm_research_experience" & a & ".csv" '----日付入りのcsvファイル
If Csv_Import_File = "False" Then Exit Sub 'キャンセルなら終了'
b = ThisWorkbook.path & "/" & Csv_Import_File '------- バス付きのファイル名

Worksheets("csv_data").Activate ' csv_dataのシートをアクティブにする'

' ● -------------- rm_published_paper 論文発表データの取込-------◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆

Csv_Import_File = "rm_published_papers" & a & ".csv" '----日付入りのcsvファイル<<<<<<<<<<<
If Csv_Import_File = "False" Then Exit Sub 'キャンセルなら終了'
b = ThisWorkbook.path & "/" & Csv_Import_File '------- バス付きのファイル名

Worksheets("csv_data").Activate ' csv_dataのシートをアクティブにする'

Set wb = Workbooks.Open(b)
Sheets(1).Cells.Copy ThisWorkbook.Sheets("csv_data").Range("A1") '全てのデータをこのブックの「CSVデータ取込み」シートにコピー'
wb.Close savechanges:=False

For i = 3 To 100 ' -----------------------------------------------------------------------------------著者名の整形----50列目に表示
str = Cells(i, 8).Value 'Authors name
Str1 = Replace(str, "[", "")
Str2 = Replace(Str1, "]", "")
Str3 = Replace(Str2, ",", ", ")
Cells(i, 50).Value = Str3
Next i

For i = 3 To 100
str = Cells(i, 16).Value 'Jounal name
Str1 = Cells(i, 17).Value ' Volume
Str2 = Cells(i, 19).Value ' Start page
Str3 = Cells(i, 20).Value ' End page
Str4 = Left(Cells(i, 14), 4) ' Year
Cells(i, 51).Value = str & ", " & Str1 & ": " & Str2 & "-" & Str3 & " (" & Str4 & ")" '加工された発表論文情報----51列目に表示
Next i

For i = 3 To 100
str = Cells(i, 50).Value ' Processed Authors name
Str1 = Cells(i, 6).Value ' Title
Str2 = Cells(i, 51).Value 'Processed Journal name
Cells(i, 100).Value = str & ", " & Str1 & ", " & Str2 '-------------------------------「Authors, Title, Journal, Year」を100列目表示する。
Next i

With Worksheets("csv_data")
.Range(.Cells(2, 1), .Cells(50, 100)).Copy
End With

With Worksheets("rm情報収集") '「論文発表データ」は、100行目にペーストする。
.Range(.Cells(101, "E"), .Cells(101, "E")).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With


With Worksheets("csv_data")
.Range(.Cells(2, 1), .Cells(50, 100)).Copy
End With

With Worksheets("papers") '「論文発表データ」は、100行目にペーストする。
.Range(.Cells(2, 1), .Cells(50, 100)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With



Sheets("rm情報収集").Activate



' ● -------------- rm_presentations 学会発表データの取込ーーーー<<<<<<<<<<<<<<<<<<<

Csv_Import_File = "rm_presentations" & a & ".csv" '----日付入りのcsvファイル<<<<<<<<<<<
If Csv_Import_File = "False" Then Exit Sub 'キャンセルなら終了'
b = ThisWorkbook.path & "/" & Csv_Import_File '------- バス付きのファイル名

Worksheets("csv_data").Activate ' csv_dataのシートをアクティブにする'

For i = 3 To 100 ' 著者名の整形
str = Cells(i, 7).Value 'Authors name
Str1 = Replace(str, "[", "")
Str2 = Replace(Str1, "]", "")
Str3 = Replace(Str2, ",", ", ")
Cells(i, 50).Value = Str3
Next i

For i = 3 To 100
str = Cells(i, 9).Value ' 学会名
Str1 = Cells(i, 11).Value '年月日
'Str2 = Cells(i, 19).Value ' Start page
'Str3 = Cells(i, 20).Value ' End page
'Str4 = Left(Cells(i, 14), 4) ' Year
Cells(i, 51).Value = str & ", " & Str1 '& ": " & Str2 & "-" & Str3 & " (" & Str4 & ")" '加工された発表論文情報
Next i

For i = 3 To 100
str = Cells(i, 50).Value ' Processed Authors name
Str1 = Cells(i, 5).Value ' Title
Str2 = Cells(i, 51).Value 'Processed Journal name
Cells(i, 100).Value = str & ", " & Str1 & ", " & Str2 '100列目に「Authors, Title, Journal, Year」を表示する。
Next i

With Worksheets("csv_data")
.Range(.Cells(1, 1), .Cells(50, 100)).Copy
End With

With Worksheets("rm情報収集") '300行目にペーストする。
.Range(.Cells(300, "E"), .Cells(300, "E")).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With

Sheets("rm情報収集").Activate

End Sub

::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

４）次に、所定のWordファイルにrm情報を転記するマクロですが、

予めWordファイルには、

たとえば、氏名を書くべきところに、[氏名]を置いておく必要があります。

以下のマクロを実行すると、転記するべきWordファイル名を聞いてきます。

::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Sub C_Wordへの転記()

'プログラム2｜変数設定
Dim i As Long, k As Long
Dim waitTime As Variant

Dim myTitle As String
Dim myMsg As String
Dim myWord_File As String

Dim WF As String

'プログラム3｜シート設定
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("rm情報収集") 'ワークシートを指定している。

'プログラム4｜エクセルの最終行と最右列を取得
' Dim cmax As Long, cnt As Long
' cmax = Range("A65536").End(xlUp).Row
' cnt = Range("IV1").End(xlToLeft).Column

myTitle = "転記するWordファイル名"
myMsg = "転記するWordファイル名を入力して下さい。"
myWord_File = Application.InputBox(Prompt:=myMsg, Title:=myTitle, Default:=1, Type:=2) 'Type:=2は、文字列入力を指定している。

'プログラム5｜ワード起動
Dim wdapp As Word.Application
Set wdapp = CreateObject("Word.application")
wdapp.Visible = True

'プログラム6｜テンプレートワードのパス取得
Dim path As String
WF = ThisWorkbook.path & "\" & myWord_File & ".docx" '<<<<<<<<<<<<

Worksheets("使い方").Cells(24, "Q").Value = WF '＜＜＜＜＜＜Wordファイルの確認

'プログラム7｜エクセルのデータを1行ずつ処理
'For i = 2 To cmax

'プログラム8｜テンプレートワードを開く
Dim wddoc As Word.Document
Set wddoc = wdapp.Documents.Open(WF)
waitTime = Now + TimeValue("0:00:10")
Application.Wait waitTime

'プログラム9｜テンプレートワードにエクセルデータを挿入●●●●●●●●●●●●●●●●●●●●●●●
With wddoc.Content.Find
.Text = "[職・氏名]" '＜------------探し出す文字列
.Forward = True
.Replacement.Text = ws.Range("CZ5").Value '置換する文字列
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With

With wddoc.Content.Find
.Text = "[氏名]" '＜------------探し出す文字列
.Forward = True
.Replacement.Text = ws.Range("CF5").Value '置換する文字列
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With

With wddoc.Content.Find
.Text = "[学位]" '＜------------探し出す文字列
.Forward = True
.Replacement.Text = ws.Range("AX5").Value '置換する文字列
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With

With wddoc.Content.Find
.Text = "[職位]" '＜------------探し出す文字列
.Forward = True
.Replacement.Text = ws.Range("AQ5").Value '置換する文字列
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With

With wddoc.Content.Find
.Text = "[所属]" '＜------------探し出す文字列
.Forward = True
.Replacement.Text = ws.Range("CP5").Value '置換する文字列
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With




For k = 1 To 5 '------論文5報を転記する。●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●

Dim part1 As String
Dim part2 As String
Dim longText As String
Dim p1 As String
Dim p2 As String

longText = Worksheets("rm情報収集").Cells(101 + k, "CZ").Value '複数の論文を置換していく。

' 長いテキストを分割
part1 = Left(longText, 255) ' 255文字まで
part2 = Mid(longText, 256) ' 残りの部分

p1 = "[論文" & k & "part1]"
p2 = "[論文" & k & "part2]"


With wddoc.Content.Find
.Text = p1 '＜------------探し出す文字列-------[論文+k+part1]
.Forward = True

.Replacement.Text = part1 '置換する文字列
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With

With wddoc.Content.Find
.Text = p2 '＜------------探し出す文字列-------[論文+k+part2]
.Forward = True

.Replacement.Text = part2 '置換する文字列
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With

Worksheets("使い方").Cells(26, "Q").Value = part1 'part1の確認
Worksheets("使い方").Cells(27, "Q").Value = part2 'part2の確認

Next '***************論文の文字列を置換している。



For k = 1 To 5 '--------学会発表５つを転記する。●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●●

'Dim part1 As String
'Dim part2 As String
'Dim longText As String
'Dim p1 As String
'Dim p2 As String

longText = Worksheets("rm情報収集").Cells(301 + k, "CZ").Value '302行目に最初の学会発表があるので。

' 長いテキストを分割
part1 = Left(longText, 255) ' 255文字まで
part2 = Mid(longText, 256) ' 残りの部分

p1 = "[学会発表" & k & "part1]" '＜------------探し出す文字列---
p2 = "[学会発表" & k & "part2]" '＜------------探し出す文字列---


With wddoc.Content.Find
.Text = p1 '＜------------探し出す文字列---
.Forward = True

.Replacement.Text = part1 '置換する文字列
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With

With wddoc.Content.Find
.Text = p2 '＜------------探し出す文字列---
.Forward = True

.Replacement.Text = part2 '置換する文字列
.Wrap = wdFindContinue
.MatchFuzzy = True
.Execute Replace:=wdReplaceAll
End With

Worksheets("使い方").Cells(26, "Q").Value = part1 'part1の確認
Worksheets("使い方").Cells(27, "Q").Value = part2 'part2の確認

Next '***************論文の文字列を置換している。



'プログラム10｜データを差し込んだワードを印刷
'wddoc.PrintOut

'プログラム11｜ワードファイルを保存
Dim str As String
str = ws.Range("A2").Value & myWord_File & ".docx"
wddoc.SaveAs Filename:=ThisWorkbook.path & "\" & myWord_File & "転記済み.docx" '<<<<<<<<<<<<

'プログラム12｜テンプレートワードを保存せずに閉じる
wddoc.Close savechanges:=False

'プログラム13｜オブジェクト解放
Set wddoc = Nothing

'プログラム14｜エクセルにデータを出力
ws.Range("B2").Value = Now & "処理済"

' Next

'プログラム15｜ワードをアプリケーションごと閉じる
wdapp.Quit
Set wdapp = Nothing

End Sub

:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

「rm情報転記マクロ」というエクセルファイルを作り、

「csv_data」と「rm情報収集」というワークシートを作成して、

上記の２つのマクロを実行すれば、所定のWordファイルに

rm情報を転記してくれるはずです。

255文字までしか文字変数に入れられないので、どうしたらいいか、ChatGTPに聞いてみたら、

' 長いテキストを分割
part1 = Left(longText, 255) ' 255文字まで
part2 = Mid(longText, 256) ' 残りの部分

と回答があったので、これを採用しました。

以上