常連

回答者

ベストアンサー

自己紹介

### 開発環境
3台分ございます。
①期待通りの動作をするマシン その１
OS:Windows10 Home 64bit
Office(Excel):Home and Business 2019 64bit

②期待通りの動作をするマシン その２
OS:Windows10 Pro 64bit
Office(Excel):Home and Business 2016 64bit

③期待通りに動作しないマシン（改善したい対象）
OS:Windows10 Home 64bit
Office(Excel):Professional Plus 2016 32bit

### 前提・要件
お世話になります。初質問のため、至らぬ点がございましたら
申し訳ございませんがご教示ください。

ExcelVBAにて、とある機能のユーザーフォーム(例：test_main.xlsm)を開発しております。
ユーザーフォームはtest_main.xlsmを起動時に即表示するようになっております。
こちらのユーザーフォームは起動時の要件として、以下がございます。

要件
①test_main.xlsmのブックを表示できないようにすること（他ブックが開かれていない場合はエクセルのアプリケーション自体を表示しないこと）
②他ブックへの影響を与えないこと（例：application.visible=falseなどは他ブックも巻き込んでしまうためNG）
③test_main.xlsmの起動前後で開いているブックを全て閉じてもtest_main.xlsmのフォームが閉じられないこと（巻き込まれないこと）

### ソースコード
上記の要件を満たすため、ソースコードを以下のように組みました。
「test.xlsm」と「test_main.xlsm」の2ファイルがございますが、「test.xlsm」から起動して「test_main.xlsm」を呼び出す構成です。


test.xlsm
```
'MicroSoft Excel Objects->ThisWorkbook
Private Sub Workbook_Open()

    Const MAIN_MACRO_NAME As String = "test_main.xlsm"
    Dim exApp As Excel.Application
    
    'ブックの非表示
    Windows(ThisWorkbook.Name).Visible = False
    
    '別プロセスでフォーム用マクロを起動
    Set exApp = CreateObject("Excel.Application")
    exApp.EnableEvents = True
    exApp.Workbooks.Open ThisWorkbook.Path & "\" & MAIN_MACRO_NAME
    exApp.Visible = False
    Set exApp = Nothing
    
    '開かれているブックがこの起動用マクロのみならExcelを終了する
    If Workbooks.Count = 1 Then
        Application.Quit
    
    End If
    
    'この起動用マクロのブックを閉じる
    ThisWorkbook.Close

End Sub
```
test_main.xlsm
```
'MicroSoft Excel Objects->ThisWorkbook
Private Sub Workbook_Open()

    'ブックの非表示
    Windows(ThisWorkbook.Name).Visible = False
    'ユーザーフォームの表示
    UserForm1.Show vbModeless
    
End Sub
```
```
'フォーム->UserForm1
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    'プロセスが残らないようにする用の処理
    If CloseMode = 0 Then
        If Workbooks.Count = 1 Then
            Application.Quit
        
        End If
        
        ThisWorkbook.Close
        
    End If

End Sub
```




### 発生している問題
上記のマクロを実行した結果、開発環境①②では要件を全て満たせておりました。
しかし、開発環境③で実行すると要件③を満たせていないことが分かりました。
開発環境③の場合、ユーザーフォーム表示後に別のブック(適当なxlsxファイルなど)を開き、そのブックを閉じた場合にユーザーフォームも一緒に閉じられてしまいます。（複数ブックを開いている場合は最後のブックを閉じた場合に）

※ユーザーフォーム起動前に適当なブックを開く→ユーザーフォーム起動→最初に開いたブックを閉じる　の場合はユーザーフォームは閉じられないため問題なし。

###考えられる原因
上記の実行結果を見比べた際に、以下のことが分かりました。
開発環境①②で実行した場合は、ユーザーフォーム用マクロと後に開いたブックは別プロセスとなっている。（期待通り）
開発環境③で実行した場合は、ユーザーフォーム用マクロと後に開いたブックは同じプロセスになってしまっている。

（Officeの64bitと32bitによる挙動の違い…？）

### 実現したいこと
開発環境③の場合でも要件③を満たすため、ユーザーフォームを起動後に別ブックを開いて閉じてもユーザーフォームはプロセスに残るようにしたいです。

よろしくお願いいたします。

### 試したこと
①test_main.xlsmの変数exAppの型をObject型に変更し、事前バインディングから実行時バインディングになるようにしてみた。
⇒変化なし。
②test.xlsm起動時にtest_main.xlsm用のExcelObjectを生成する前にあらかじめダミーのマクロでExcelObjectを生成する。
ダミーの内容はWorkbook_Openイベント内で「Windows(ThisWorkbook.Name).Visible = False」のみ。
⇒test_main.xlsmとは別プロセスになり、後から開いたブックもダミーのプロセスに吸収されることを確認した。（先に開いたExcelプロセスが優先される？）
しかし、後から開いたブックを全て閉じればダミーのプロセスが消滅し、次回からブックを開いた際はtest_main.xlsmのプロセスが吸収してしまう。

ExcelVBA ユーザーフォームを表示後に別ブックを表示し、表示したブックを全て閉じてもユーザーフォームは残るようにしたい

# 解決したいこと

VBAで円グラフの各要素の色付けについて、要素名称で判別し、要素毎に色付けできるようにしたいです。

# 発生している問題・エラー

要素名が格納されていると思われる、chart.SeriesCollection.point.Nameに名称ではない値が格納されており（S1P1、S1P2等）、上記ロジックが組めません。項目名称はどこに格納されていますか。もしくは、どのようなプログラムを組めば良いでしょうか。

# 該当するソースコード

Dim cht As Chart
Dim seriesnum As Integer
Dim datanum As Integer
Dim colormax As Integer
Dim pointnum As Integer
Dim chttype As Long
Dim i As Integer
Dim j As Integer

　Set cht = ActiveChart '選択中のグラフ
　With cht
　seriesnum = .SeriesCollection.Count '系列数取得

　For i = 1 To seriesnum '系列数分ループ
　　　With .SeriesCollection(i)
　　　　　・・・

　　chttype = .charttype 'グラフ種別取得

　　Select Case chttype
　　　Case 5, 68, 69, 70, 71, -4102, -4120 '円グラフ
　　　　pointnum = .Points.Count '要素数
　　　　　For j = 1 To pointnum
　　　　　　With .Points(j)
　　　　　　　g_name = .Name
　　　　　　　（.NameにS1P1、S1P2といった値が格納されています。）

【補足情報】
　OS　：　Windows10
　OFFICE　：　Microsoft Office 2019

VBAで円グラフの色付けを項目名をキーに行いたいです

お世話になります。
役所へ定型で報告をしなければならないのですが、
毎月100名以上の日別に特定条件にものを入力しなければならず、
作業に時間がかかる上に間違いが多いため
VBAで作業時間を短縮したいと考えています。
現状1日ずつのデータを別シートへの転記まではできたのですが、
31回繰り返すために、行を一つずらすたびにすべてのデータを直す必要があるのと、
特定条件が反映されないために困っています。
もし可能であるならば、どこを省略すればよいのか教えていただければ有難いです。
よろしくお願いいたします。

### 前提・実現したいこと
実現したいこと
**シート１「貼付用」の名前、登校時間(1号認定のみ)、降校時間
シート２「転記用」の認定、年齢
をシート３「1号」とシート４「2号」へ下記の要件で転記。**

---
＜シート３＞
下記のように入力されるようにしたいです。
![イメージ説明](19871098cc7b24a067fd8dc096ea9bd2.png)
(１)シート２のC列が新1号,新2号,新3号のどれかで、
　　かつF列が有の人で、シート1で対象に登園時間が9:00より前に１度でも
　　来ている人をシート３に抽出して、下記のように転記。
時間帯には朝と入力され、該当者の名前、年齢、9時より前に来た日の時刻を入力。
(２)シート２のC列が新1号,新2号,新3号のどれかで、
　　かつF列が有の人で、シート1で対象に下校時間が15:30以降に１度でも
　　下校している人をシート３に抽出して、下記のように入力。
　　・15時半以降の場合には該当者の名前と年齢、15時半以降になった日の時刻をを入力。
※9；00より前に利用し、かつ15時30分(含む)を利用した人は2行記載される。
　登校のみ、もしくは、下校のみ該当した場合は1行記載される。
　非該当の人は転記されない。

＜シート４＞
![イメージ説明](29da576479156e1c56e06384ee876700.png)
シート2のC列が1または標かつF列が有の人対象に抽出し、
(1)シート2が1の人は、1か月の間に1回でも16：30以降の場合
　D,E列が1,F~Hに児童名、年齢、該当日の下校時刻(ex.1800)を転記
(2)シート2が標の人は、1か月の間に1回でも18：00以降の場合
　D,E列が空白,F~Hに児童名、年齢、該当日の下校時刻(ex.1800)

---

**転記するための情報のシートは２つあります。**
シート１：貼付用(他ソフトからのCSVをそのまま貼付)
![イメージ説明](1c3a4eb2f437b335d7eb651a3704d48b.png)
A 整理番号(標準)
B　名前(標準)
C　所属(標準)
D　園(標準)
E　日付(date)
F 　曜日(標準)
G  出欠(標準)
H　登校時刻(TIME)
I　外出時刻(TIME)
J  戻り時間(TIME)
K　下校時間(TIME)

シート２：転記用
![イメージ説明](41a83b781260d2827a0b29268cff0336.png)
A 整理番号(標準)
B　名前(標準)
C 認定(標準)…１,新1号,新2号,新3号,標,空白のどれか
D 誕生日(日付)
F 年齢(=DATEDIF(D3,$G$2,"Y"))
F　在籍(標準) …有か無のどちらか
G2～Ak2　〇日(=IF(ISERROR(DATE($A$1,$B$1,〇)),"",IF(MONTH(DATE($A$1,$B$1,〇))=$B$1,DATE($A$1,$B$1,〇),""))
G3～Ak203 時間(TIME)
AL 免除(標準)…1か空白のどちらか

**また転記先のシートの情報は下記のとおりです。**
シート３：1号
![イメージ説明](25e77360ba64eb5da97e9d8fce07aefd.png)
A　番号(標準)
B~C　時間帯(標準)…朝か空白のどちらか
D~F　児童名(標準)
G,H  年齢(標準)
I25~AM40 時刻(標準)　該当時刻を入力するが8：00だった場合800と表示
AN~AI 料金(標準)
AQ 実費(標準)
AR　利用料(標準)
AS,AT 利用日数(=IF(AND(D10<>D11,D11=D12),"",IF(D10=D11,SUM(AS10:AS11),AS11)))
AU,AV　免除(標準)

シート４：2号
![イメージ説明](1ad2b28981ce54a9391edb068508c506.png)
C　番号(標準)
D,E 標・短(標準)  1か空白のどちらか
F,G 児童名(標準)
I,J 年齢(標準)
K24～AO224 時刻(標準)　該当時刻を入力するが17：00だった場合1700と表示
AP~AR 金額(オリジナル数式を作成予定…同ではない場合は、相当長い数式を入力予定)
AS,AT 免除　1か空白のどちらか

以上です。


■■な機能を実装中に以下のエラーメッセージが発生しました。

### 発生している問題・エラーメッセージ


```
転記用に転記する際に、認定で該当する人のものだけを転記しようとしているが、誰も転記されない。
また、1日ごとのコードのため、一つ直すごとにすべての日にちを直す必要があるため、整理がつかなくなっています。
```

### 該当のソースコード

```ここに言語名を入力

Sub 一日()
Dim sh1, sh2
Set sh1 = Worksheets("貼付用")
Set sh2 = Worksheets("転記")
d = sh1.Range("A65536").End(xlUp).Row
On Error Resume Next
For i = 2 To d
'--条件をかけて選別
If sh1.Cells(i, "G") = "出席" And sh1.Cells(i, "E") = sh2.Range("G2") And _
sh1.Cells(i, "K") <> "" Then
t = sh1.Cells(i, "A")
'---Ｓｈｅｅｔ２で時刻行を探す
For r = 2 To 200
If sh1.Cells(i, "A") = sh2.Cells(r, "A") Then Exit For
Next r
'--該当行の値をＳｈｅｅｔ２の時刻該当行セット
Sheet2.Cells(r, "B") = sh1.Cells(i, "B")
Sheet2.Cells(r, "G") = sh1.Cells(i, "K")
End If
Next i
End Sub
```

### 試したこと

認定部分を反映させるために
Sub 一日()
Dim sh1, sh2
Set sh1 = Worksheets("貼付用")
Set sh2 = Worksheets("転記")
d = sh1.Range("A65536").End(xlUp).Row
On Error Resume Next
For i = 2 To d
'--条件をかけて選別
If sh2.Cells(i, "C") = "標" And sh1.Cells(i, "E") = sh2.Range("G2") And _
sh1.Cells(i, "K").Value > TimeSerial(17, 59, 99) Then
t = sh1.Cells(i, "A")
'---Ｓｈｅｅｔ２で時刻行を探す
For r = 2 To 1000
If sh1.Cells(i, "A") = sh2.Cells(r, "A") Then Exit For
Next r
'--該当行の値をＳｈｅｅｔ２の時刻該当行セット
Sheet2.Cells(r, "B") = sh1.Cells(i, "B")
Sheet2.Cells(r, "G") = sh1.Cells(i, "K")
End If
Next i
End Sub

や

Sub 一日()
Dim sh1, sh2
Set sh1 = Worksheets("貼付用")
Set sh2 = Worksheets("転記")
d = sh1.Range("A65536").End(xlUp).Row
P_TIME = TimeValue("15:30")
S_TIME = TimeValue("16:30")
L_TIME = TimeValue("18:00")
Certification = sh1.Cells(i, "C")

Select Case Certification
    Case Is = "標"
On Error Resume Next
For i = 2 To d
'--条件をかけて選別
If sh1.Cells(i, "G") = "出席" And sh1.Cells(i, "E") = sh2.Range("G2") And _
sh1.Cells(i, "k") >= L_TIME Then
t = sh1.Cells(i, "A")
'---Ｓｈｅｅｔ２で整理番号を探す
For r = 2 To 1000
If sh1.Cells(i, "A") = sh2.Cells(r, "A") Then Exit For
Next r
'--該当行の値をＳｈｅｅｔ２の時刻該当行セット
Sheet2.Cells(r, "B") = sh1.Cells(i, "B")
Sheet2.Cells(r, "G") = sh1.Cells(i, "K")
End If
Next i

Case Is = "1"
On Error Resume Next
For i = 2 To d
'--条件をかけて選別
If sh1.Cells(i, "G") = "出席" And sh1.Cells(i, "E") = sh2.Range("G2") And _
sh1.Cells(i, "k") >= S_TIME Then
t = sh1.Cells(i, "A")
'---Ｓｈｅｅｔ２で整理番号を探す
For r = 2 To 1000
If sh1.Cells(i, "A") = sh2.Cells(r, "A") Then Exit For
Next r
'--該当行の値をＳｈｅｅｔ２の時刻該当行セット
Sheet2.Cells(r, "B") = sh1.Cells(i, "B")
Sheet2.Cells(r, "G") = sh1.Cells(i, "K")
End If
Next i

Case Else
On Error Resume Next
For i = 2 To d
'--条件をかけて選別
If sh1.Cells(i, "G") = "出席" And sh1.Cells(i, "E") = sh2.Range("G2") And _
sh1.Cells(i, "k") >= P_TIME Then
t = sh1.Cells(i, "A")
'---Ｓｈｅｅｔ２で整理番号を探す
For r = 2 To 1000
If sh1.Cells(i, "A") = sh2.Cells(r, "A") Then Exit For
Next r
'--該当行の値をＳｈｅｅｔ２の時刻該当行セット
Sheet2.Cells(r, "B") = sh1.Cells(i, "B")
Sheet2.Cells(r, "G") = sh1.Cells(i, "K")
End If
Next i
End Select
End Sub

**---本来であれば、
転記シートに一度貼り付けシートの時刻を転記せずに、
そのまま必要部分をシート３およびシート２に転記できればよかったのですが、
一気に別シートまで条件付きでシートを転記する方法が思い浮かばず、
一度転記シートに時間を転記した後に
該当する人のみをート３及びシート４に転記しようとしました。
が、その行為自体は出来る方からすると2度手間かもしれませんので、
省けるのであれば省きたいです。**
### 補足情報（FW/ツールのバージョンなど）

Excel 2019 windows10
ここにより詳細な情報を記載してください。

別シートに該当したデータを転記したい

###環境
Windows10 Pro Ver.1903
Office365 Ver.2002 (12527.20988)

###発生事象
8/31(月)ACCESSで作成した一部フォーム（10フォーム）が突然表示されなくなりました。
8/28(金)まで約１年間特に問題なく表示されていたフォームです。
- フォームは全てポップアップ「はい」で作成。（全21フォーム）
- デザイン／レイアウトビューは正常に表示される。

以前ACCESS 2010を利用していた頃、同じ現象が発生したことがあり、
その時は以下操作で解消しましたが、今回は解消しませんでした。
0. 表示されなくなったフォームのポップアップを「いいえ」で一旦保存。
0. 再度、同フォームのポップアップを「はい」で再保存。

データベースの最適化／修復を行っても解消しませんでした。

###自己解決した対処方法
表示されなくなったフォーム全ての「開く時」イベントプロシジャーを作成し、
Me.Refreshを記述したところ、元通り表示されるようになりました。
```VBA
Private Sub Form_Open(Cancel As Integer)
    Me.Refresh
End Sub
```

###質問事項
フォーム構成情報が何らかの原因で破損（？）したのでしょうか？
また、今回自己解決した対処方法以外の対処方法をご存じでしたらご教示頂きたく。

本件はMicrosoftコミュニティにも報告しましたが、今のところ原因・対処方法について
書き込みはありません。
[ACCESS 突然フォーム（ポップアップ）が表示されなくなりました](https://answers.microsoft.com/ja-jp/msoffice/forum/all/access/ee5938f9-69ef-4714-b3b3-468256b2ece6)

【原因不明】突然ポップアップフォームが表示されなくなりました（一応自己解決）

### 前提・実現したいこと
未だ研究室に属していない学生の身分ですのでレポート作成においてグラフを描画するには専らExcelを用いています．科学的なグラフではデータの位置を表すプロットの上を線が通るか通らないかということは大きな意味を持ちます．プロットより表面に線が来ていれば，それはそのプロットを確実に線が通っているということを意味し，逆に線がプロットの背面であればプロットを通っているとは言えず，近似的な意味を持ちます．しかし，Excelの近似曲線では系列より表面に描画されてしまい，"近似"ではなくなってしまいます．近似式を取得して近似曲線の系列を作り，マーカーなしにしてマーカー同士を結べば元のデータ系列のマーカー背面に位置させることができますが，科学実験で得られるデータは不規則なことやデータ間が広いことがしばしばあり，結ばれる線がヨレヨレに見えることがあります．理論的には近似曲線の系列を十分に細かくとってやれば滑らかに見えますが，どんな場合でも滑らかに見えるような区切り方となると無限に細かくせざるを得ません．当然そんなことをすればExcelもPCも悲鳴をあげます．そこで白抜きにしたいグラフを複製し，片方をマーカーのみ，もう片方をマーカー以外見えるようにして背景の塗りつぶしを無くしてぴったり重ねる方法を取ります．ぴったり重ねるにはグラフシートにマーカー以外を表示しているグラフを移動させ，そこにオブジェクトとしてマーカーのみのグラフを移動させて，最大化しています．
Rなら白抜きプロットは簡単にできるのですが，細かな体裁の調整はExcelの方が簡易で，VBAのコードもほぼ完成に近いためこのままExcelで成し遂げたいと思います．

### 発生している問題・エラーメッセージ
実は上記の手法をVBAで書くことは下記のコードでほぼ達成されています．現在問題となっているのは2つ以上の系列に近似曲線を描画し，凡例をグラフに重ねずに付けた上で下記のコードを実行すると，重ね合わせるグラフがずれてしまうことです．

原因はマーカーのみ表示のグラフの方で近似曲線を透明化して凡例に表示されている近似曲線も透明化された際，Excelが要らぬ気を利かせて凡例の幅を自動調整し，結果としてプロットエリアの幅が広くなり，マーカー以外表示のグラフとずれてしまうことです．「近似曲線を透明化しても凡例の近似曲線はそのまま」や「凡例の自動調整を無効にする」などこの問題の解決に妙案ありましたらご教授頂けますでしょうか．

### 該当のソースコード

```VBA
Option Explicit
Sub Macro1()
Dim PlotCha As ChartObject
Dim LineCha As ChartObject
Dim OriginSh As Worksheet
Dim LineName As String
'On Error Resume Next
    Set LineCha = ActiveChart.Parent
    LineName = LineCha.Name
    Set OriginSh = ActiveSheet
    If LineCha Is Nothing Then
        MsgBox "白抜きプロットにするグラフを選んでから実行してください．", Title:="手順ミス"
        Exit Sub
    End If
    LineCha.Chart.ChartArea.Copy
    Range("A1").Select
'Application.ScreenUpdating = False
    OriginSh.Paste
    Set PlotCha = Selection.Parent.Parent
Dim PlotName As String
    PlotName = LineName & "Copy"
    PlotCha.Name = PlotName
    With OriginSh.Shapes(LineName)
        .Fill.Visible = msoFalse
        .Line.Visible = msoFalse
    End With
    With LineCha.Chart
Dim i As Long
        For i = 1 To .FullSeriesCollection.Count
            .FullSeriesCollection(i).MarkerStyle = xlMarkerStyleNone
        Next i
Dim ChartSh As String
        ChartSh = "Sheet_" & LineName
        .Location xlLocationAsNewSheet, Name:=ChartSh
    End With
    With OriginSh.Shapes(PlotName)
        .Fill.Visible = msoFalse
        .Line.Visible = msoFalse
    End With
    With PlotCha.Chart
        .ChartArea.Format.TextFrame2.TextRange.Font.Fill.Transparency = 1
        With .Axes(xlCategory)
            .MajorGridlines.Format.Line.Visible = msoFalse
            With .Format
                .Line.Visible = msoFalse
                .Fill.Visible = msoFalse
            End With
        End With
        With .Axes(xlValue)
            .MajorGridlines.Format.Line.Visible = msoFalse
            With .Format
                .Line.Visible = msoFalse
                .Fill.Visible = msoFalse
            End With
        End With
Dim j As Long
        For j = 1 To .FullSeriesCollection.Count
            With .FullSeriesCollection(j)
Dim k As Long
                For k = 1 To .Trendlines.Count
                    .Trendlines(k).Format.Line.Visible = msoFalse
                Next k
            End With
            .FullSeriesCollection(j).Format.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
        Next j
        .Location xlLocationAsObject, Name:=ChartSh
    End With
    With Sheets(ChartSh).Shapes(PlotName)
        .ScaleWidth 2.0341434821, msoFalse, msoScaleFromTopLeft
        .ScaleHeight 2.2135414844, msoFalse, msoScaleFromTopLeft
        'マクロの記録で得られた値ですが，この数値で良いのか，また，そもそもメソッドとして最大化の（マーカー以外表示グラフのサイズに合わせる）方法はないのか思案中です．
    End With
    ActiveChart.ChartArea.Copy
    OriginSh.Pictures.Paste.Select
'Application.ScreenUpdating = True
End Sub
```

### 試したこと

凡例をグラフに重ねて表示しているものに上記コードを実行するとずれることはありません．また，凡例をグラフに重ねずに表示しているものに上記コードを実行後，グラフシートに作成されたマーカーのみのグラフの幅を少し狭めるとマーカーが正しい位置に来る点があります．これらのことから，やはり凡例の幅が縮まったことによってプロットエリアの幅が広くなり，重ねた際のズレを生み出していると考えられます．実際，適当なグラフを作って凡例をグラフに重ねずに表示し，近似曲線を手動で透明化するとプロットエリアが広くなる様子が見て取れます．

### 補足情報（FW/ツールのバージョンなど）
PC
MacBook Air，Intel Core i5-5250U，Boot CampによりWindows 10 Homeにて運用
Excel
2016 32ビット，バージョンは最新の状態

###追記1
回答を受けまして，「変更点」と示した部分に設定された色を取得して再設定するコードを付加しました．2020年8月25日17時01分
```VBA
Option Explicit
Sub Macro1()
Dim PlotCha As ChartObject
Dim LineCha As ChartObject
Dim OriginSh As Worksheet
Dim LineName As String
'On Error Resume Next
    Set LineCha = ActiveChart.Parent
    LineName = LineCha.Name
    Set OriginSh = ActiveSheet
    If LineCha Is Nothing Then
        MsgBox "白抜きプロットにするグラフを選んでから実行してください．", Title:="手順ミス"
        Exit Sub
    End If
    LineCha.Chart.ChartArea.Copy
    Range("A1").Select
'Application.ScreenUpdating = False
    OriginSh.Paste
    Set PlotCha = Selection.Parent.Parent
Dim PlotName As String
    PlotName = LineName & "Copy"
    PlotCha.Name = PlotName
    With OriginSh.Shapes(LineName)
        .Fill.Visible = msoFalse
        .Line.Visible = msoFalse
    End With
    With LineCha.Chart
Dim i As Long
        For i = 1 To .FullSeriesCollection.Count
            .FullSeriesCollection(i).MarkerStyle = xlMarkerStyleNone
        Next i
Dim ChartSh As String
        ChartSh = "Sheet_" & LineName
        .Location xlLocationAsNewSheet, Name:=ChartSh
    End With
    With OriginSh.Shapes(PlotName)
        .Fill.Visible = msoFalse
        .Line.Visible = msoFalse
    End With
    With PlotCha.Chart
        .ChartArea.Format.TextFrame2.TextRange.Font.Fill.Transparency = 0.99
        With .Axes(xlCategory)
            .MajorGridlines.Format.Line.Visible = msoFalse
            With .Format
                .Line.Visible = msoFalse
                .Fill.Visible = msoFalse
            End With
        End With
        With .Axes(xlValue)
            .MajorGridlines.Format.Line.Visible = msoFalse
            With .Format
                .Line.Visible = msoFalse
                .Fill.Visible = msoFalse
            End With
        End With
Dim j As Long
        For j = 1 To .FullSeriesCollection.Count
            With .FullSeriesCollection(j)
Dim k As Long
                For k = 1 To .Trendlines.Count
                    With .Trendlines(k).Format.Line
Dim LineCol As Variant
                        LineCol = .ForeColor
                        .ForeColor.RGB = RGB(LineCol Mod 256, Int(LineCol / 256) Mod 256, Int(LineCol / 256 / 256)) '変更点
                        .Transparency = 0.99
                    End With
                Next k
            End With
            .FullSeriesCollection(j).Format.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
        Next j
        .Location xlLocationAsObject, Name:=ChartSh
    End With
    With Sheets(ChartSh).Shapes(PlotName)
        .ScaleWidth 2.0341434821, msoFalse, msoScaleFromTopLeft
        .ScaleHeight 2.2135414844, msoFalse, msoScaleFromTopLeft
    End With
    ActiveChart.ChartArea.Copy
    OriginSh.Pictures.Paste.Select
'Application.ScreenUpdating = True
End Sub
```
###追記2
実際のグラフは動作確認用ですが以下のような感じです．2020年8月25日17時14分
データ
![データ](8ceca6d577df723fc6572c876ba69fff.jpeg)
マクロ実行前に選択されるグラフ
![実行前グラフ](e427f2ecf3f50ca23482403e5b745ea1.jpeg)
実行後にグラフシートにて背面に来るグラフ（マーカー以外表示グラフ）
![マーカー以外表示グラフ](5d5ffaf8b6bee756e57957e3002f9f3f.jpeg)
実行後にグラフシートにて表面に来るグラフ（マーカーのみ表示グラフ）
　実行前グラフの近似曲線の色を取得して，同色を単色として再設定し，透明度99%に設定
![マーカーのみ表示グラフ](2af181b9b447199a89223e50d4cfc191.jpeg)
グラフシートにて重なった2つのグラフ
![完成グラフ](8ec9c7895ec24def1281c3c820364b24.jpeg)
###追記3
追記1の通り一応望むものはごり押しでできました．今暫く回答受付中にしますので，これよりスマートな記述法がありましたらご教授願います．これが最適である場合にはその旨を教えて下さると幸いです．2020年8月25日17時18分
###追記4
追記2にて重なったグラフ（完成グラフ）を載せるのを忘れていましたので修正しました．2020年8月25日17時22分

Excelのグラフで近似曲線を透明化すると凡例の幅が自動調整されてしまう

APIのPOST送信をした際に、JSON形式で受け取るようにしています。

その際に配列で返ってくる項目があるのですが、配列の1項目ずつを
セルに移したいです。
ご教授よろしくお願いします。
```ここに言語を入力
'API接続し、セルに入力する
Dim objhttp As Object
    Set objhttp = CreateObject("MSXML2.XMLHTTP")

        With objhttp
          .Open "POST", url, False
          .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
          .setRequestHeader "Content-Type", "application/json"
          .setRequestHeader "X-access-token", apitoken              
          .setRequestHeader "X-contract-id", apikey
          .Send (Nippou & proc)　　　’この部分はPOST送信の処理名を送っています。
          JSON = .responseText
        End With
              
        Set Parse = JsonConverter.ParseJson(JSON)

  
    Dim num As Long
    Dim resultCount As Long
    num = 1
    resultCount = 1
     
    Dim lastrow As Long
  With wsNippou
           lastrow = 2
    
   For i = 1 To count
        DoEvents
      
          For j = 0 To ArrayCount
          
          .Cells(lastrow, num).Value = Parse("result")(resultCount)(nippou_array)
     
          num = num + 1
        
      Next j
          lastrow = lastrow + 1
          resultCount = resultCount + 1
          num = 1
          
        '1秒間スリープさせる
          Sleep 1000
        
 　　Next i
  End With
End Sub

```
```
APIレスポンス結果
{"total_count":"1","result":[{"taxDetailList":[{"tax":10,"Total":20,"TargetTotal":30,]}]}
```

VBA　APIから受け取った配列を格納するためには

3剤3期クロスオーバークロスオーバーの分散分析を、Rで実行しました（以下Rプログラム）。
この分散分析表の誤差「8.5089」をエクセルで算出したいのですが、結果が合いません。
（誤差以外は検算できました。）
以下、エクセルの画像を添付しました。
どこの解釈が違うのか、どなたかアドバイスをお願いしてもよろしいでしょうか。
データは「医薬品開発のための統計解析 第2部p.282」です。

```
group<-factor(c(c(rep(1,9)),c(rep(2,9)),c(rep(3,9))))
id<-factor(rep(1:9, each=3))
period<-factor(rep(c(1,2,3),9))
treat<-factor(c(rep(c(1,2,3),3),rep(c(3,1,2),3),rep(c(2,3,1),3)))
y<-c(7.2,6.6,7.9,8.4,8,7.1,9.2,10.7,8.8,7.9,8.2,9.2,7.8,9.7,10.1,6,9.4,10.2,5.6,6.8,9.2,6.4,6.2,8.6,7.3,7.3,9.5)
(anova<-anova(lm(y~group+treat+id*group+period)))

#          Df  Sum Sq Mean Sq F value   Pr(>F)   
#group      2  7.5822  3.7911  6.2377 0.011561 * 
#treat      2 10.4422  5.2211  8.5905 0.003678 **
#id         6 11.4978  1.9163  3.1530 0.035919 * 
#period     2 12.1756  6.0878 10.0165 0.001993 **
#Residuals 14  8.5089  0.6078

#Residualsの「8.5089」をエクセルで計算したい。  
```

![!![イメージ説明](8b7fa5c7b09c807d10e96c2b1a30dea0.jpeg)各データの残差の2乗の合計が「8.5089」になるはずが「7.29」になっている。

■個人差の計算式です。
例えば、g1,id1の個人差-0.98
7.23-8.21=-0.98

■残差の計算式です。
例えば、g1,id1,period1の7.2に当たる残差-0.09
7.2-(8.27+(-0.98))=-0.09

※以下追記します。
2剤2期クロスオーバーの分散分析では同様の方法で算出しました。
3剤3期クロスオーバーの分散分析では同様の方法では算出できないのでしょうか。
![エクセル2](2f49bca55a1f4e84b6f8bbcf01a86d19.png)

3剤3期クロスオーバーの分散分析：誤差をエクセルで算出したい

Excel365にて，リストから同じ列を判別してその列または何か値を抽出する方法を探しています。

具体的には以下のように元の数字の羅列から全通りの組み合わせを作成します。

   元データ  		組み合わせを全通り作成		返り値用
0	0	0		0	0	0	　　　　　　　	0
1	1	1		0	0	1	　　　　　　　	1
2	2	2		0	0	2		　　　　　　　2
3	3	3		0	0	3		　　　　　　　3
4	4	4		0	0	4		　　　　　　　4
5	5	5		0	0	5		　　　　　　　5
6	6	6		0	0	6		　　　　　　　6
7	7	7		0	0	7		　　　　　　　7
8	8	8		0	0	8		　　　　　　　8
9	9	9		0	0	9		　　　　　　　9
　　　　　　　　　　　　　　　　（以下省略）

その後，別シートの　2 1 0　の組み合わせが，作成した組み合わせのどの位置にあるかをシート100枚ほど判別していきたいと考えています。

これをもとにクラスタリングを行っていくため，単純に上からの行番号が返ってきても，返り値用の値でも構いません。

シート数が多いのと，この作業がいくつかあるのでできれば自動化したいと考えていますが，手作業でもなにか良い方法はありませんでしょうか。

ご教示いただけますと幸いです。

（画像1）
![イメージ説明](e567438f493bbb125aee1f0c74a07356.png)

（画像2）
![イメージ説明](b19c589fc807de82379bd07bb9511c13.png)

エクセルで，リストから同じ列を判別してその列または何か値を抽出する方法

お助け頂きたいですm(_ _)m

VBAでパワーポイントの指定スライドをアクティブにしたいです。
例えば、5ページ中の、3ページ目をアクティブにする、という意味です。
基礎の基礎で簡単に見えるのですが、どうしても動いてくれません。
どこが問題なのか分からず、解決法をご教示頂けるととても助かります。

※以下のコードの最下段の「**PPTPlz.Slides(2).Select**」が機能しません・・。
　ググると出てくる↓↓の二つも、「コンパイルエラー 拡張子が不正です」とエラーメッセージが出て、そもそも動かなくなります。
　　**ActiveWindow.View.GotoSlide Index:=2**
　　**ActivePresentation.Slides(2).Select**

**【VBAコード】**
```
Sub PPTのスライドを移動したい()

'変数定義
Dim objPpt As Object
Dim PPTPlz As Object 'PowerPointプレゼン
Dim objTitle As Object
Dim pptSld As Object 'PowerPointスライド
Dim PPTW As Single
Dim PPTH As Single
Dim i As Variant, j As Variant

On Error Resume Next
  
'動作を非表示にする
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
   
   strPPTFullPath = "保存する際のPPT名です.pptx"
   Set objPpt = CreateObject("PowerPoint.Application")
   
   objPpt.Visible = True
   objPpt.Presentations.Add
   Set objFile = objPpt.ActivePresentation
           
   With PPTPlz.PageSetup
      PPTH = .SlideHeight
      PPTW = .SlideWidth
   End With
 
'別途Excelファイルがあり、「PPT」というシートの情報を参照してグラフを貼っています
Worksheets("PPT").Activate
'ExcelのD列をカウント→一番下の行まで処理を繰り返す
For i = 3 To Worksheets("PPT").Range("D3").End(xlDown).Row
      
   Dim sh As String
       sh = Sheets("PPT").Range("F" & i)
       Worksheets(sh).Activate
      
   'グラフオブジェクト選択
      ActiveSheet.ChartObjects(Worksheets("PPT").Range("D" & i)).Activate
      Worksheets(sh).ChartObjects(Worksheets("PPT").Range("D" & i)).Copy
        
   'PowerPointスライド追加
   Set PPTPlz = objFile.Slides.Add(Index:=i - 2, Layout:=12)
        
   '貼り付け
   PPTPlz.Shapes.PasteSpecial DataType:=6
   PPTPlz.Shapes.PasteSpecial MsoTriState:=False
   With PPTPlz.Shapes(1)
      .Top = 60
      .Left = 0
   End With

Next i

    'スライド移動
    PPTPlz.Slides(3).Select

End Sub
```

以上、何卒、よろしくお願い致します。