常連

VBA初心者です・・
違うパソコンのブックにVBAで転記がしたいです。

同じパソコン上ではVBAが作動するのですが、違うパソコンでそのブックを開いて同じ処理をしようとしても「インデックスが有効ではありません」とでます。

workbooks("例").worksheets("例").range("例")
↑一緒のパソコン内だったら作動します。
違うパソコンだと上記の通りエラーがでて作動しません。
ブック名などは間違っていないことは確認しています。

もしよろしければ教えてください。


違うパソコンのブックにVBAで転記

エクセルマクロ初心者です。

あるシートのB11セルからH列までのデータが入っている最終行までコピーして、
別のシートのデータの後ろに貼り付けたいと思っています。

下記、コードを書いてみましたが、うまくいくときと、行かない時があります。
うまくいかないときは、なぜか、B1～H11セルがコピーされてしまいます。

初心者故根本的なミスがあるのかもしれません。
調べてみましたがわからず質問させていただきました。

ご教示ください。

```ここに言語を入力
 Dim NextRow As Long
 Dim Clm As Long
 Clm = 1
    
    '「work」の最後行の取得
    NextRow = ws3.Cells(Rows.Count, Clm).End(xlUp).Row + 1
    
    '一番左のWSからB11～H列をコピーして、「work」の最後行に値貼り付けする
    With Worksheets(1)
        .Range("B11:H" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy
            ws3.Cells(NextRow, Clm).PasteSpecial Paste:=xlPasteValues
       End With
```

VBA初心者　基点からデータのあるすべてのコピーがうまくいかない　

変動するデータ数に合わせて表を作成したいです。
Sheet1のA1:D1にはデータがあり、Sheet2はA4横スタイルでA1:D1、E列は空欄、F1:I1にデータを入れたいです。

①Sheet1からSheet2へデータをコピーすることはできましたが、
データは一つ目の表にしか入れることが出来ず、二つ目の表にデータが入りません。
（印刷ページで言うと、一ページ目しか出来ません。）
データの数に合わせて表も自動で出来るようにしたいです。

②表のA1:D1とF1:I1にデータを入れるためにfor文を使っていますが、
i=i+1を2回も入れるのはくどい気がするのですが、こういう事もあるのでしょうか。

![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2022-02-04/5e162728-3d1f-49ae-b28a-03b2694dd6bc.png)

完成イメージを追加しました。

参考サイトです。
[リンク内容](https://www.wordvbalab.com/code/6946/)

```ここに言語を入力
 Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim Rowmax As Integer
    Dim mytable As table
        
    'すべての改ページを削除
    ActiveSheet.ResetAllPageBreaks
        
    lastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
   'ページ数設定 (ここでページ数を作成しているつもりです)
　Rowmax = Round((lastRow - 1) / 2)
    
    
            For i = 2 To lastRow '該当データを用紙の右側に貼り付け
            
            For j = 2 To 24
            
            i = i + 1
       
                ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 4)).Copy Destination:=ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 4))
        
            Next j
    
            For k = 1 To 24  '用紙の左側に貼り付け
            i = i + 1
                
                ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 4)).Copy Destination:=ws2.Range(ws2.Cells(k, 6), ws2.Cells(k, 9))
    
    
            Next k
    
       
        'ページが増えるごとに改ページを追加
        If Range("A" & i).Value <> Range("A" & i - 1).Value Then
            ActiveSheet.HPageBreaks.Add Before:=Range("A" & i)
        End If
        
        Next i

 'フォント設定
    With ws2
        ws2.Range("A1:I25").Font.Name = "HG正楷書体-PRO"
        ws2.Range("A1:I25").Font.Size = 15
        
    End With

      
    '表の作成

    With ws2
        .Range("A:D").RowHeight = 18
        .Range("F:I").RowHeight = 18
        .Range("A:A").ColumnWidth = 21
        .Range("B:B").ColumnWidth = 13
        .Range("C:C").ColumnWidth = 15
        .Range("D:D").ColumnWidth = 7
        .Range("F:F").ColumnWidth = 21
        .Range("G:G").ColumnWidth = 13
        .Range("H:H").ColumnWidth = 15
        .Range("I:I").ColumnWidth = 7
        
        .Range("A2:D24").Borders.LineStyle = xlContinuous
        .Range("F2:I24").Borders.LineStyle = xlContinuous
        .Range("A2:D24").Borders.ColorIndex = 15
        .Range("F1:I24").Borders.ColorIndex = 15
    End With

End Sub

```

excel vba データの数に合わせて表を作成したい

コードの左にある白い線を消したいのですがどうすれば良いでしょうか？
![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2022-01-29/d51ef8d9-da6c-4092-b5bf-c8e7ff41f1f2.png)

microsoft visual basic for applications　のコードの左の線を消したい

### 前提・実現したいこと
VBAで作成したcsvファイルを別Excelに取込む際、すべてのデータを文字列として表示したい。

### 発生している問題・エラーメッセージ
文字列データが日付形式で表示される。

### 試したこと
・データを``”``で囲む
例）"01-01" → 1月1日

・各データの先頭に``’``をつける
例）'01-01 → '01-01 （``’``まで表示されてしまう）
※``’``を置換&削除すると日付で表示される

・取込む際に各列の表示形式を「文字列」に設定すると解決するが、取込む度に設定するのは面倒なので不採用

### csv出力のソースコード
```VBA
Sub CSV出力_Click()
    Dim filePath As String ' 保存先のパス
    Dim firstRow As Long ' 開始行
    Dim firstCol As Long ' 開始列
    Dim lastRow  As Long ' 終了行
    Dim lastCol  As Long ' 終了列6
    Dim i As Long ' For文用
    Dim j As Long ' For文用
    Dim line As String ' 1行分のデータ

    ' 保存先のパスを取得
    filePath = ActiveWorkbook.Path & Format(Now(), "yymmdd") & ".csv"
    
    ' 作成するファイルを開く
    Open filePath For Output As #1
    
    ' CSV作成
     With Sheets("csv出力シート")
        '「データ」シートの開始行を取得
        firstRow = .ListObjects(1).Range.Cells(1, 1).row
        '      〃          開始列を取得
        firstCol = .ListObjects(1).Range.Cells(1, 1).Column
        '      〃          終了行を取得
        lastRow = .Cells(Rows.Count, 1).End(xlUp).row
        '      〃          終了列を取得
        lastCol = .Cells(6, Columns.Count).End(xlToLeft).Column
        
        For i = firstRow To lastRow
            line = ""
            ' 非表示と1列目が空白のデータは出力しない
            If .Rows(i).Hidden = False And .Range(.Cells(i, 1).Address).value <> "" Then
                For j = firstCol To lastCol
                    line = line & """" & .Range(.Cells(i, j).Address).value & """" & ","
                Next
                Print #1, line
            End If
        Next
    End With

    ' 作成するファイルを閉じる
    Close #1
    
    MsgBox "本マクロを起動したフォルダに、CSVファイルを作成しました。", vbInformation, "出力完了"

End Sub
```

### 補足情報（FW/ツールのバージョンなど）
csvファイルを右クリック→プログラムから開く→Excel
でcsvファイルを取込むのでcsv出力する際のVBAの修正で解決したいのですが、方法はございますでしょうか。

Win 10
Excel 2019

Excel　csvファイル取込時、文字列が日付に自動変換されるのを防ぐ方法

### 前提・実現したいこと

別シートから検索し，検索結果を転記する

### 発生している問題・エラーメッセージ

検索セルに入力した結果が転記はされるのですが，一致ではない（おそらく文字を含む？2文字目まで？）値までも抽出されてしまいます。添付写真は【FCD450】を検索検索したものでｓ
### 該当のソースコード
 Sub Sort材質_抽出転記()
 
    Dim ws01, ws02 As Worksheet
    Dim I, M, lRow, mRow As Long
    Dim kensaku As String
    
    Set ws01 = Worksheets("FC材質") '転記前総データ
    Set ws02 = Worksheets("成分（2020年1月1日~)") '転記先
    
    
    mRow = ws02.Cells(Rows.Count, "A").End(xlUp).Row 'シート「成分（2020年1月1日~)」の最終行を取得
    ws02.Range("A3:P" & mRow + 1).Clear  'シート「成分（2020年1月1日~)」にある前回の結果データをクリアー
    
    
    kensaku = ws02.Range("B1")  '検索する材質を「kensaku」へ代入
    lRow = ws01.Cells(Rows.Count, "A").End(xlUp).Row
 
    mRow = 3  'シート「成分（2020年1月1日~)」に転記する開始行の3行目を設定
    
    
    For I = 12 To lRow
        
        If ws01.Cells(I, "B") Like "[[]" & kensaku & "[]]*"Then'シート「転記前総データ」から指定した材質に該当するデータを検索する。
            ws02.Range("A" & mRow & ":P" & mRow).Value = ws01.Range("A" & I & ":P" & I).Value  '検索条件に該当する材質をシート「成分（2020年1月1日~)」に転記する
            mRow = mRow + 1  '転記する行に対して＋１加算する。
        End If
    
    Next I
    
    ws02.Range("A3:P" & mRow - 1).Borders.LineStyle = xlContinuous 'シート「成分（2020年1月1日~)」に転記されたデータの最終行まで罫線を引く
      
End Sub

 

### 試したこと

ここに問題に対して試したことを記載してください。

### 補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

【VBA】抽出し，転記するマクロを組んだのですが，余計なモノまで抽出されてしまいます

### 前提・実現したいこと

ここに質問の内容を詳しく書いてください。
ソースコード上のCells(j.Row,"B")Selectの部分でJ.Rowに数字が格納されていますが、
セレクトが機能しません。
こちらの解決方法を教えてください。  

### 発生している問題・エラーメッセージ
座標を選択できない。
```
エラーメッセージ
```

### 該当のソースコード
```ここに言語名を入力
Private Sub CommandButton1_Click()

Dim i As Integer
Dim j As Range
Dim shName As String
Dim What As String
i = 1

Do Until i > 12
'追加した場合はi>〇を変更する

Worksheets(1).Activate
On Error Resume Next
Range(Cells(5 + i, 3), Cells(5 + i, 8)).Copy
shName = Cells(5 + i, 2).Value
If shName = vbNullString Then Exit Sub

Sheets(shName).Activate

Set j = Range(Cells(38, 1), Cells(97, 1)).Find(What:=Cells(1, 10).Value)

If j Is Nothing Then
MsgBox "見つかりませんでした。"
End If

Cells(j.Row, "B").Select
ActiveCell.PasteSpecial Paste:=xlPasteValues

i = i + 1
Loop

End Sub

```

### 試したこと

ここに問題に対して試したことを記載してください。

### 補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

VBAの動作不良について教えてください。

お世話になっております。

シートに図形と入力規則のあるセルが存在します。
シートの保護をかけると、図形も入力規則も保護され、入力規則で選択した内容をオートフィルすることができません。セルの保護を外しているのですが、入力規則の▼もオブジェクトなんですね。
保護をかけるときに「オブジェクトの編集」にチェックを入れると、入力規則でのオートフィルはできますが、図形で右クリックをして編集できてしまいます。困りました。。

希望は以下の通りです。
シートの保護をかけたときに、
・図形は保護したい。
・入力規則セルは選択後にオートフィルできるようにしたい。

です。

VBAでも大丈夫です。何とかお知恵を拝借できませんでしょうか。
また、現在は何とかならないかと思っていますが、それは不可能です！ということがはっきりとわかればあきらめますのでどうぞご教示よろしくお願いいたします。

シート保護で入力規則でオートフィルするには

### 前提・実現したいこと
VBAで登録ボタンを作成し、動作としては
➀A1セルの空白セルを選択
➁受付番号、氏名、会社名、電話番号を左からInputBoxを使い入力し表を作成
その際にセルも移動させる
➂新規データを、その都度書き足していく

###質問
質問1,電話番号のデータ形式が、
➀Stringだと携帯電話の090xxxxxxxx（11ケタ）のうち、先頭の0を抜かした
数字しか入らない。例,90xxxxxxxx（10ケタ）と表示される

➁Longだと、オーバーフローになる

質問2,A1セルの空白セルの選択、横のセル(B→C→D)に入力できるが、入力中はセルが移動しない


### 該当のソースコード
Sub 新規データ登録ボタン()
    
    Dim 受付番号 As String
    Dim 氏名 As String
    Dim 会社名 As String
    Dim 電話番号 As String
    
    受付番号 = Application.InputBox("受付番号は（11桁で入力して下さい）", "受付番号")
    氏名 = Application.InputBox("フルネーム　カタカナで入力して下さい", "氏名")
    会社名 = Application.InputBox("会社名を入力して下さい", "会社名")
    電話番号 = Application.InputBox("電話番号を入力して下さい", "電話番号")
    
    With Cells(Rows.Count, 1).End(xlUp)
        .Offset(1, 0) = 受付番号
        .Offset(1, 1) = 氏名
        .Offset(1, 2) = 会社名
        .Offset(1, 3) = 電話番号
    End With
End Sub

```ここに言語名を入力
VBA
```



### 補足情報
まだ実装してないですが
受付番号は11ケタの英数字
氏名はカナ
電話番号は12ケタ上限の**数字のみ**

お分かりの方いらっしゃいましたらどうか助言をお願いします

VBA、InputBoxを使っての入力表示について

VBAで今度は勤怠管理システムを作らなければならなくなったのですが
年月日を指定してその日に登録した出退勤時間を呼び出して数字を修正することは可能なのでしょうか・・？

下記画像が出退勤時間を登録する画面です(シートはApplication.Visible = False　で非表示状態）
![![イメージ説明](7def43bd4429e145255fb8ce243df09b.png)](f3e0e432a52665a3a64a9a00f6d098b9.png)

生年月日をプルダウンで選んで読み込みボタンを押すと
出退勤、休憩時間がそれぞれに表示されるようにしたいのですが・・・。

※登録した時間はシートの方に追加されていきます。
![イメージ説明](6722395381c1e4e26cfe5b4dc13dd272.png)







一番先頭のシートを・・・とか、シート名で指定して・・・なら方法がありますが
上記のようなやり方はあるのでしょうか。

近いやり方等でも教えていただけると幸いです。


### 発生している問題・エラーメッセージ

```

```

### 該当のソースコード

```
Private Sub cb_touroku_Click()                      '登録ボタン
    Dim tgtRow As Long
    tgtRow = Cells(Rows.Count, 1).End(xlUp).Row
    tgtRow = tgtRow + 1
    
    
    With Sheet3　　　　　　　　　　　　　　　　　　　　　　　’プルダウンで数字を選択します
        .Cells(tgtRow, 1).Value = Me.cb1.Value　　　　'2021年のみ
　　　　 .Cells(tgtRow, 2).Value = Me.cb2.Value          '月選択
        .Cells(tgtRow, 3).Value = Me.cb3.Value        '1~31　　　日
        .Cells(tgtRow, 4).Value = Me.cb4.Value　　　　　'1~24　　　時間
        .Cells(tgtRow, 5).Value = Me.cb5.Value　　　　　　'1~00   分
        .Cells(tgtRow, 6).Value = Me.cb6.Value　　　　　　'1~24　　　時間
        .Cells(tgtRow, 7).Value = Me.cb7.Value　　　　　　'1~00   分
        .Cells(tgtRow, 8).Value = Me.cb8.Value           '1~24　　　時間
        .Cells(tgtRow, 9).Value = Me.cb9.Value           　'1~00   分
        .Cells(tgtRow, 10).Value = Me.cb10.Value         '1~24　　　時間
        .Cells(tgtRow, 11).Value = Me.cb11.Value       '1~00   分
         
    End With
    
    MsgBox "登録しました"
       
End Sub

Private Sub UserForm_Initialize()
    With cb1
        .AddItem "2021"
    End With
    With cb2
        .AddItem "1"             
        .AddItem "2"
        .AddItem "3"
        .AddItem "4"
        .AddItem "5"
        .AddItem "6"
        .AddItem "7"
        .AddItem "8"
        .AddItem "9"
        .AddItem "10"
        .AddItem "11"
        .AddItem "12"
    End With

    With cb3
        .AddItem "1"
        .AddItem "2"
        .AddItem "3"
        .AddItem "4"
        .AddItem "5"
        .AddItem "6"
        .AddItem "7"
        .AddItem "8"
        .AddItem "9"
        .AddItem "10"
        .AddItem "11"
        .AddItem "12"
        .AddItem "13"
        .AddItem "14"
        .AddItem "15"
        .AddItem "16"
        .AddItem "17"
        .AddItem "18"
        .AddItem "19"
        .AddItem "20"
        .AddItem "21"
        .AddItem "22"
        .AddItem "23"
        .AddItem "24"
        .AddItem "25"
        .AddItem "26"
        .AddItem "27"
        .AddItem "28"
        .AddItem "29"
        .AddItem "30"
        .AddItem "31"
    End With

※以下、cb4～も同様の記述

```


### 試したこと



### 補足情報（FW/ツールのバージョンなど）

指定した年月日でデータを読み込み、上書き修正するやり方　(VBA,Excel)

csvに、"0から始まる数字"や"文字列"、"0以外の数字"が入り混じっているとき。
0から始まる数字を表示させたいです。
下記のコードで取り込み、保存した後にメモ帳で確認すると0から始まる数字の"0"が消えてしまいます。
Format関数を使用するにも値が定まっていないので、使用できないです。
こういった場合の対応方法をご教示いただければ幸いです。

ws.Cells(l, 3).NumberFormatLocal = "@"

```VBA
Sub Shiftjis()

 Dim selectFileName As Variant
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Worksheets("Sheet1")
 
    '//ダイアログを開く
    ws.Cells.Clear '//ファイルクリア
    selectFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _
                                        Title:="CSVファイルの選択")
        If selectFileName = False Then
        Exit Sub
        End If

        With ws.QueryTables.Add(Connection:="text;" & selectFileName, Destination:=ThisWorkbook.Worksheets("Sheet1").Range("A1"))
            .TextFilePlatform = 65001       '//UTF8に設定
            .AdjustColumnWidth = False      '//列の幅を自動計算しない
            .TextFileCommaDelimiter = True  '//コンマ区切り
            .Refresh BackgroundQuery:=False '//シートに出力
            .Delete
        End With
    DoEvents

'//使用セルの最終行を取得
     Dim fin_line As Long, l
            With ws.UsedRange
                fin_line = .Rows(.Rows.Count).Row
            End With
    For l = 2 To fin_line

'//処理（Sheet2のセルの値を書き込む）
    ws.Cells(l, 2).NumberFormatLocal = "@" 
    ws1.Cells(l, 2).Value = "'" & Format("0", "000")

'//保存するブックの名前を作成
          ws1.Copy
           a = Format(Now(), "yyyymmdd-hhmm") '日時
           B = ThisWorkbook.Path & "\" & filename1 & a & ".csv"

         '//新しく作成したブックを名前を付けて保存
        ActiveWorkbook.SaveAs filename:=B, FileFormat:=xlCSV
        ActiveWorkbook.Close


End Sub
```

VBA　先頭の０を表示させたい。

VBAでの電卓作成です。昨日に引き続き問題個所が新たに出てきて、これ以上自分ではどこをどう修正すれば
良いのか解らないので、質問させていただきます。


### 発生している問題・エラーメッセージ

以下のような現象が出てしまいます(発見出来てないだけで他にもあるかもしれませんが・・)

(1)a-b = c 若しくは　a/b = c　の後に「+」、「×」「-」、「÷」を押すと0或いは1になる　
(2)axb = c　若しくはa+b = c の後に「+」、「×」、「-」、「÷」を押すと　cが足されて
　クリックするごとに加算されていく


例えば(2)の場合、1+1＝2の後に　2×2とやったら4になるようにしたいですが
現状だと「×」を押しただけでそのまま2が加算されて4になります。


### 該当のソースコード

```
Option Explicit

Dim ans As Double      '答えを保持
Dim num As Double
Dim ent As Integer     '分岐する変数　1は+、2は-、3は*、4は/
Dim enzan As Boolean   'ture;+-*/ falseそれ以外　条件を指定した結果を保

Private Sub CommandButton1_Click()

If enzan = False Then
    If TextBox1.Text = "0" Then
       TextBox1.Text = "1"
       
Else
     TextBox1.Text = TextBox1.Text & "1"

    End If
    Else
     TextBox1.Text = "1"
     enzan = False

End If

End Sub

※２～９ボタンも上記と同様です。

Private Sub CommandButton12_Click()        '-　引き算
    
    enzan = True
    num = Val(TextBox1.Text)

    Select Case ent
    Case 0
        ans = num
    Case 1
        ans = ans + num
    Case 2
        ans = ans - num
    Case 3
        ans = ans * num
    Case 4
        ans = ans / num
    End Select

    TextBox1.Text = ans
    ent = 2
    
End Sub

Private Sub CommandButton13_Click()    '*　掛け算

    enzan = True
    num = Val(TextBox1.Text)

    Select Case ent
    Case 0
        ans = num
    Case 1
        ans = ans + num
    Case 2
        ans = ans - num
    Case 3
        ans = ans * num
    Case 4
        ans = ans / num
    End Select

    TextBox1.Text = ans
    ent = 3

End Sub

Private Sub CommandButton14_Click()    '/　　割り算
    
    enzan = True
    num = Val(TextBox1.Text)

    Select Case ent
    Case 0
        ans = num
    Case 1
        ans = ans + num
    Case 2
        ans = ans - num
    Case 3
        ans = ans * num
    Case 4
        ans = ans / num
    End Select

    TextBox1.Text = ans
    ent = 4

End Sub
Private Sub CommandButton11_Click()      '⁺　　足し算
    
    enzan = True
    num = Val(TextBox1.Text)

    Select Case ent
    Case 0
        ans = num
    Case 1
        ans = ans + num
    Case 2
        ans = ans - num
    Case 3
        ans = ans * num
    Case 4
        ans = ans / num
    End Select

    TextBox1.Text = ans
    ent = 1
    
End Sub

Private Sub CommandButton15_Click() 'イコールボタン  ここで条件分岐
    
    enzan = True
    num = Val(TextBox1.Text)
    
    If ent = 1 Then
        ans = num + ans
        TextBox1.Text = CStr(ans)
        
    End If
   
    If ent = 2 Then
        ans = ans - num
        TextBox1.Text = CStr(ans)

    End If
   
    If ent = 3 Then
        ans = ans * num
        TextBox1.Text = CStr(ans)
     
    End If
    
    If ent = 4 Then
        ans = ans / num
        TextBox1.Text = CStr(ans)
      
    End If
        
        Range("A1").Value = Str(ans)
    
End Sub

Private Sub CommandButton18_Click()        'クリアボタン
    
    ent = 0
    num = 0
    TextBox1.Text = CStr(ans)
    
End Sub

Private Sub CommandButton10_Click()    '0ボタン

If enzan = False Then
    If TextBox1.Text = "0" Then
       TextBox1.Text = ""
       
Else
     TextBox1.Text = TextBox1.Text & "0"
     
    End If
    Else
     TextBox1.Text = "0"
     enzan = False

End If
    
End Sub

Private Sub CommandButton16_Click()      'オールクリア
    
    TextBox1.Text = "0"
    ent = 0
    num = 0
    ans = 0
   
End Sub

Private Sub CommandButton17_Click()        '00ボタン
      
If enzan = False Then
    If TextBox1.Text = "0" Then
       TextBox1.Text = ""
          
Else
     TextBox1.Text = TextBox1.Text & "00"
     
    End If
    Else
     TextBox1.Text = "00"
     enzan = False

End If
      
End Sub

Private Sub CommandButton19_Click()     '小数点
     
    TextBox1.Text = TextBox1.Text & "."
 
End Sub
   
Private Sub UserForm_Click()
   
End Sub

```

### 試したこと

＝の部分のところで、一度 ans = 0 num = 0と付け加えましたが
改善されませんでした。

解決策・修正箇所などが解れば教えていただけると幸いです。

### 補足情報（FW/ツールのバージョンなど）

【補足】
・テキストボックスには同じ数字を羅列させるために一旦文字列として表しています。
ex「1111」など

・足し算は「1」、引き算は「2」、掛け算は「3」、割り算は「4」
で条件分岐するようにしています。

・オールクリアボタンを押すとテキストボックスには「0」が入るため
次に数字を押した時に「01」とか「023」などにならないようにDim enzan As Boolean で
0を上書きするようにしています。

VBAでの電卓での計算について/演算キーを押すたびに加算される、割り算引き算で0になる

### 実現したいこと

ユーザーフォームの×ボタンが押されたら、
ブックを保存せずに閉じ、かつ、プロジェクト全ての処理を終了させたいです。

### 発生している問題

ユーザーフォームのQueryCloseイベントに、
・ブックを保存せずに閉じる
・引数なしのEndステートメント（すべての処理を終了させたいため）
を記述しています。
ユーザーフォームの×ボタンを押して閉じると、
ブックを保存せずに閉じると同時に、Excelそのものが再起動されてしまいます。

```Visual Basic Excel
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

'×ボタンが押された場合
If CloseMode = 0 Then
    If MsgBox("キャンセルしますか？", vbYesNo) = vbYes Then
        Workbooks(main).Close False     'main：パブリック変数
        MsgBox "処理を中止します。", vbExclamation
        End
    Else
        Cancel = True
    End If
End If

End Sub
```

### 試したこと

###### 1) DoEventsを活用
検索して調べ、`DoEvents`を追記すれば解決するかと思い、試しました。
症状は変わりませんでした。
###### 2) Cancelをパブリック変数で共有
あるいはと考え、ユーザーフォームと標準モジュールそれぞれで
Exit Subで処理を抜けさせようかと考えました。

```Cancel As Boolean
If CloseMode = 0 Then
    If MsgBox("キャンセルしますか？", vbYesNo) = vbYes Then
        Cancel = False
        btn = Cancel    'btn：パブリック変数
        Workbooks(main).Close False     'main：パブリック変数
        MsgBox "処理を中止します。", vbExclamation
        Exit Sub
    Else
        Cancel = True
    End If
End If
```

Boolean型のパブリック変数でCancelプロパティを共有し、
標準モジュールにIf文でFalseの場合にExit Subを実行させたところ、
ブックを保存せずに閉じましたが、マクロが実行中のままExcelが固まってしまい、
マクロの実行をリセットするとExcelが再起動されます。
また、この場合の記述だと、
ユーザーフォームの本来の目的でコマンドボタンを実行した場合、
（ユーザーフォームの×ボタンを押していないのに）
標準モジュールがIf文のところで処理を抜けてしまいます。
###### 3) CloseModeをパブリック変数で共有

```CloseMode As Integer
If CloseMode = 0 Then
    If MsgBox("キャンセルしますか？", vbYesNo) = vbYes Then
        btn = CloseMode    'btn：パブリック変数
        Workbooks(main).Close False     'main：パブリック変数
        MsgBox "処理を中止します。", vbExclamation
        Exit Sub
    Else
        Cancel = True
    End If
End If
```

それならばと思い、CloseMode = 0をInteger型で共有してみました。
ですが、これもCancelを共有した場合と同様、
ブックを保存せずに閉じましたが、マクロが実行中のままExcelが固まってしまい、
マクロの実行をリセットするとExcelが再起動されます。
そしてやはり、ユーザーフォームの本来の目的でコマンドボタンを実行した場合、
標準モジュールがIf文のところで処理を抜けてしまいます。
###### 4)妥協する
ちなみにですが、妥協してブックを保存せずに閉じることを諦めれば、
マクロ実行中のまま固まったり、Excelが再起動されたりといった症状は出ません。

```妥協案
If CloseMode = 0 Then
    If MsgBox("キャンセルしますか？", vbYesNo) = vbYes Then
        MsgBox "処理を中止します。", vbExclamation
        End
    Else
        Cancel = True
    End If
End If
```

### お伺いしたいこと

ユーザーフォームのQueryCloseイベント内のみで完結させるには、
引数なしのEndステートメントしかないのでしょうか？
また、ユーザーフォームと標準モジュールそれぞれで
処理を抜けさせる方法は、他に何かあるのでしょうか？

### 補足情報

Windows10 Pro バージョン 2004
Excelのバージョン：365 ProPlus

ブックを保存せずに閉じると、Excelが再起動される。

```ここに言語を入力
Dim moto As Worksheet, saki As Worksheet
    Set moto = Sheets("A")
    Set saki = Sheets("B")
    Dim lastRow As Long
    lastRow = moto.Range("D:E").Find(What:="合計", LookAt:=xlPart).Row
    moto.Range("A6:K" & lastRow).Copy
    saki.Range("A4").Insert Shift:=xlDown
```
現在このようなコードでコピペをしております。
このコードでコピーをすると数式などもコピーしてしまいます。
値だけのコピーを教えてください。

VBA　値だけをコピー

複数シートあるExcelファイルをVBAにて特定のセルのみ抽出するプログラムをつくりたいという題目で質問させていただきます。

まず、大前提にVBAは初心者なので、文法等はわからずにいます。
最初から学ぶべきだとは思いますが、タイトルにあるVBAプログラムを作成するには何をしたらいいのかご教示いただければと思います。

まず、前提にExcelファイルは↓のような感じで、
https://docs.google.com/spreadsheets/d/1HTRb2MCt1PtAmcC8uwhGkt653jT-vyA4/edit?usp=sharing&ouid=107958392552603639319&rtpof=true&sd=true
シートが三つあり、青文字のカラムと黄色のセルが存在しています。

このうち、黄色のセルだけを抽出したいと考えています。
さらに、このようなファイルが同じディレクトリ内に複数あると想定しています。

なので、VBAでは以下のようなことをすればいいのかなと思っています。

１．特定のディレクトリを指定する
２．指定したディレクトリ内にあるエクセルファイルを一つずつ開く
３．開いたエクセルファイルの全データ・全シートを全て確認し、黄色の網掛けがついている部分のみ抽出する

イメージとしては下記な感じです。
![イメージ説明](6564d18f0cf7a7d9156322fb459ed4cc.png)


これをするにはどういったことから着手していけばいいでしょうか？
ご教授いただけますと幸いです。

複数シートあるExcelファイルをVBAにて特定のセルのみ抽出するプログラムをつくりたい

標準ではないフォントを使って表示したセルを画像化し貼り付けて
フォントがインストールされていない端末でも同様に表示させたいです。
ご教示の程よろしくお願い致します。

◆環境
Windows10
Microsoft Office Standard　2016　Excel
（16.0.5188.1000）


◆やってみた事
下記コードで実行すると画像化は出来たように見えますが、「フォントA」を
インストールしていない端末で開くと、他のフォントで表示されていました。

```VBA
Option Explicit
Sub バーコード画像化()


    Dim Rtn As String
 
    'フォントの確認
    Rtn = MsgBox("バーコードは正常に表示されていますか？", vbYesNo, "確認")
    '「はい」の場合
    If Rtn = vbYes Then
    'それ意外の場合案内をかけて動作を終了する
    Else
        MsgBox "「フォントA」をインストールしてください。" & vbCrLf & "詳しくは○○まで"
        Exit Sub
    End If




'画像に灰色の線が残らない様に目盛線を非表示
ActiveWindow.SheetViews("見本").DisplayGridlines = False
ActiveWindow.SheetViews("短縮版").DisplayGridlines = False


'見本
  
    With Worksheets("見本").Range("B18:O19")
      .Borders(xlEdgeBottom).LineStyle = False  '下線消す
      .Borders(xlEdgeLeft).LineStyle = False  '左線消す
      .Borders(xlEdgeRight).LineStyle = False  '右線消す
      .CopyPicture Appearance:=xlScreen, Format:=xlPicture  '図としてコピー
      .PasteSpecial'貼付け
      .ClearContents  '元の値を消す
      .Borders.LineStyle = True  '()内省略で上下左右縦横中線が一括選択できるが隣接セルの被った枠線は操作しない
      .Borders(xlEdgeTop).LineStyle = False  '上線消す
      
    End With


'見本２

    With Worksheets("見本").Range("B51:O52")
      .Borders(xlEdgeBottom).LineStyle = False
      .Borders(xlEdgeLeft).LineStyle = False
      .Borders(xlEdgeRight).LineStyle = False
      .CopyPicture Appearance:=xlScreen, Format:=xlPicture
      .PasteSpecial 
      .ClearContents
      .Borders.LineStyle = True
      .Borders(xlEdgeTop).LineStyle = False
      
    End With


'短縮版

    With Worksheets("短縮版").Range("B13:O14")
      .Borders(xlEdgeBottom).LineStyle = False
      .Borders(xlEdgeLeft).LineStyle = False
      .Borders(xlEdgeRight).LineStyle = False
      .CopyPicture Appearance:=xlScreen, Format:=xlPicture
      .PasteSpecial
      .ClearContents
      .Borders.LineStyle = True
      .Borders(xlEdgeTop).LineStyle = False
      
    End With
    
'目盛線を表示
ActiveWindow.SheetViews("見本").DisplayGridlines = True
ActiveWindow.SheetViews("短縮版").DisplayGridlines = True
    
End Sub
```




ネットで検索し.PasteSpecialの後ろに
 Format:="図 (PNG)", Link:=False, DisplayAsIcon:=Falseを付けてみましたが
エラー1004が表示され貼付けできません。

```VBA
Option Explicit
Sub バーコード画像化()


    Dim Rtn As String
 
    'フォントの確認
    Rtn = MsgBox("バーコードは正常に表示されていますか？", vbYesNo, "確認")
    '「はい」の場合
    If Rtn = vbYes Then
    'それ意外の場合案内をかけて動作を終了する
    Else
        MsgBox "「フォントA」をインストールしてください。" & vbCrLf & "詳しくは○○まで"
        Exit Sub
    End If




'画像に灰色の線が残らない様に目盛線を非表示
ActiveWindow.SheetViews("見本").DisplayGridlines = False
ActiveWindow.SheetViews("短縮版").DisplayGridlines = False


'見本
  
    With Worksheets("見本").Range("B18:O19")
      .Borders(xlEdgeBottom).LineStyle = False  '下線消す
      .Borders(xlEdgeLeft).LineStyle = False  '左線消す
      .Borders(xlEdgeRight).LineStyle = False  '右線消す
      .CopyPicture Appearance:=xlScreen, Format:=xlPicture  '図としてコピー
      .PasteSpecial Format:="図 (PNG)", Link:=False, DisplayAsIcon:=False '貼付け
      .ClearContents  '元の値を消す
      .Borders.LineStyle = True  '()内省略で上下左右縦横中線が一括選択できるが隣接セルの被った枠線は操作しない
      .Borders(xlEdgeTop).LineStyle = False  '上線消す
      
    End With


'見本２

    With Worksheets("見本").Range("B51:O52")
      .Borders(xlEdgeBottom).LineStyle = False
      .Borders(xlEdgeLeft).LineStyle = False
      .Borders(xlEdgeRight).LineStyle = False
      .CopyPicture Appearance:=xlScreen, Format:=xlPicture
      .PasteSpecial Format:="図 (PNG)", Link:=False, DisplayAsIcon:=False
      .ClearContents
      .Borders.LineStyle = True
      .Borders(xlEdgeTop).LineStyle = False
      
    End With


'短縮版

    With Worksheets("短縮版").Range("B13:O14")
      .Borders(xlEdgeBottom).LineStyle = False
      .Borders(xlEdgeLeft).LineStyle = False
      .Borders(xlEdgeRight).LineStyle = False
      .CopyPicture Appearance:=xlScreen, Format:=xlPicture
      .PasteSpecial Format:="図 (PNG)", Link:=False, DisplayAsIcon:=False
      .ClearContents
      .Borders.LineStyle = True
      .Borders(xlEdgeTop).LineStyle = False
      
    End With
    
'目盛線を表示
ActiveWindow.SheetViews("見本").DisplayGridlines = True
ActiveWindow.SheetViews("短縮版").DisplayGridlines = True
    
End Sub

```

セルをコピーして同じ場所に画像(PNG）として貼り付けたい

VBA初心者です。
普段から、コードはネットで調べて組み合わせて作っています。

今回、組み合わせたコードで処理を一番初めに戻って繰り返しさせたいです。
調べてみたのですが、VBAでは一番初めに戻るような処理はないのでしょうか？

今現在作ったコードでは
①データ読み取りをしたいExcelを開く、別ブックを開いて該当のセルに入力。セル自体に数式が入っているので各シートに反映されます。
②inputboxで各シートの該当セルに表示させたい文字を入力。
③3、4枚目のシートを選択。
④名前をつけて保存する。

という内容です。この1-４までの作成した処理を1番はじめまで戻って同じ処理を繰り返したいのですが、参考になる記事等が見つかりません。

なにかヒントをいただけないでしょうか。
よろしくお願いします。

```    Dim RC As Integer
    Dim OpenFileName, fileName, Path, SetFile As String
    Dim wbMoto, wbSaki As Workbook

    Set wbMoto = ActiveWorkbook  'マスターデータ取り込み元をセット

    Application.DisplayAlerts = False

    RC = MsgBox("マスターデータ取込みますか？", vbYesNo + vbQuestion, "確認")

    If RC = vbYes Then

            OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
            'ダイアログボックスを表示して、マスターデータファイルを指定します。

            If OpenFileName <> "False" Then
                 SetFile = OpenFileName
            Else
                MsgBox "キャンセルされました"
                Exit Sub  'マスターデータの取り込みをキャンセル
            End If


            Workbooks.Open fileName:=SetFile, ReadOnly:=True, UpdateLinks:=0
            'ダイアログボックスで指定したマスターデータファイルを開きます。

            Set wbSaki = Workbooks.Open(Path & SetFile)

                'ワークブック間のシート「項目」をコピーします。
                wbSaki.Worksheets("内訳書").Range("D:O").Copy
                wbMoto.Worksheets("見積入力").Range("U7").PasteSpecial xlPasteValues


                Application.CutCopyMode = False  'コピー切り取りを解除
                wbSaki.Close False  'マスターデータ取り込み先のファイルを閉じる

        Else

        MsgBox "処理を中断します"

    End If

    Application.DisplayAlerts = True

     Dim ans As String
    ans = InputBox("見積書・請求書No", "", "")

    If ans <> "" Then
       wbMoto.Worksheets("見積(").Range("I3").Value = ans
       Worksheets("見積").Range("I3").Value = "あいう-" & ans

    End If

        Application.DisplayAlerts = True


    ans = InputBox("見積書発行日", "", "")

    If ans <> "" Then
       wbMoto.Worksheets("見積").Range("F11").Value = ans
    End If

    ans = InputBox("完工日", "", "")

    If ans <> "" Then
       wbMoto.Worksheets("請求").Range("F11").Value = ans
    End If

        ans = InputBox("請求書発行日", "", "")

    If ans <> "" Then
       wbMoto.Worksheets("請求").Range("F12").Value = ans
    End If

    Worksheets(Array(2, 3)).Select               '3 番目と 4 番目のシートを選択
    
    Dim xFile
    xFile = Application.GetSaveAsFilename( _
    FileFilter:="Excelファイル, *.xlsm")
    If TypeName(xFile) <> "Boolean" Then
    ActiveWorkbook.SaveAs FileName:=xFile
    End If
    End Sub
'
'

コード
コード
```

ちなみに、ファイルを順番に開き、上書き保存して閉じるといったコードは見つけました。
```Sub フォルダの中に含まれるファイルを順に編集する

Dim FolderName As String　’文字列を入れる変数として「FolderName」を使う
Dim index As Integer　’数字を入れる変数として「index」を使う
Dim FileName As String　’文字列を入れる変数として「FileName」を使う
FolderName = Application.GetOpenFilename’ダイアログを用いて選択したファイルのパスをFolderNameとする①
If FolderName = “False” Then’FolderNameが選択されていなければ作業を終了する
Exit Sub
End If
’今のフォルダ名には選択したファイル名含まれているので、ファイル名の部分を切り取る作業。
index = InStrRev(FolderName, “\”)’フォルダ名部分の文字数をカウントする
FolderName = Left(FolderName, index)’ カウントした文字数までの部分を切り取ってフォルダ名とする
FileName = Dir(FolderName & “*xls*”)’ フォルダの中に含まれるファイルを取り出す
Do While FileName <> “”’ ファイルがなくなるまで繰り返す
Workbooks.Open FolderName & FileName’ファイルを開く
Cells(1,1) = 1’ 変更を行う
Workbooks(Workbooks.Count).Save
Workbooks(Workbooks.Count).Close
FileName = Dir() ’
Loop

End Sub
コード
```


追って、ご教授いただいたコードを追加したのですが、Nextに対応するForがありません。とエラーが出ます。
```'
Sub マスターデータ取込03()  '選択したファイルを取り込み、別のファイルに貼り付ける。

For Each f In fso.GetFolder(folderpath).Files
If fso.GetExtensionName Like "xls?" Then
    Set wb = Workbooks.Open(f)
    
    Dim RC As Integer
    Dim OpenFileName, FileName, Path, SetFile As String
    Dim wbMoto, wbSaki As Workbook

    Set wbMoto = ActiveWorkbook  'マスターデータ取り込み元をセット

    Application.DisplayAlerts = False
    
    RC = MsgBox("マスターデータ取込みますか？", vbYesNo + vbQuestion, "確認")
    
    If RC = vbYes Then
            
            OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
            'ダイアログボックスを表示して、マスターデータファイルを指定します。
            
            If OpenFileName <> "False" Then
                 SetFile = OpenFileName
            Else
                MsgBox "キャンセルされました"
                Exit Sub  'マスターデータの取り込みをキャンセル
            End If
    
            
            Workbooks.Open FileName:=SetFile, ReadOnly:=True, UpdateLinks:=0
            'ダイアログボックスで指定したマスターデータファイルを開きます。
            
            Set wbSaki = Workbooks.Open(Path & SetFile)
            
                'ワークブック間のシート「項目」をコピーします。
                wbSaki.Worksheets("内訳書").Range("D:O").Copy
                wbMoto.Worksheets("見積入力").Range("U7").PasteSpecial xlPasteValues
                 
                
                Application.CutCopyMode = False  'コピー切り取りを解除
                wbSaki.Close False  'マスターデータ取り込み先のファイルを閉じる
  
        Else
        
        MsgBox "処理を中断します"
    
    End If
  
    Application.DisplayAlerts = True
    
     Dim ans As String
    ans = InputBox("見積書・請求書No", "", "")

    If ans <> "" Then
       wbMoto.Worksheets("見積").Range("I3").Value = ans
       Worksheets("見積").Range("I3").Value = "ＶＨＭ-" & ans

    End If
    
        Application.DisplayAlerts = True
    
     
    ans = InputBox("見積書発行日", "", "")

    If ans <> "" Then
       wbMoto.Worksheets("見積").Range("F11").Value = ans
    End If
    
    ans = InputBox("完工日", "", "")

    If ans <> "" Then
       wbMoto.Worksheets("請求").Range("F11").Value = ans
    End If

        ans = InputBox("請求書発行日", "", "")

    If ans <> "" Then
       wbMoto.Worksheets("請求").Range("F12").Value = ans
    End If
    
    Worksheets(Array(2, 3)).Select               ' 1 番目と 2 番目のシートを選択
    
    Dim xFile
    xFile = Application.GetSaveAsFilename( _
    FileFilter:="Excelファイル, *.xlsm")
    If TypeName(xFile) <> "Boolean" Then
    ActiveWorkbook.SaveAs FileName:=xFile
    End If
    
Next
     
    End Sub

コード
```

【VBA】一番初めの処理に戻って、同じ作業を繰り返すことはできないのでしょうか？

エクセルvbaで処理が無限ループします。
あるデータ表からfor文で上から順にvlookup関数で該当するデータを出力し、データが間違いor空欄の場合は次の行にスキップして繰り返す…という処理を作ろうとしたのですが、以下文だとマクロそのものが無限にループしてしまいます。
On error Resume Next文も試したのですが、そうすると今度はエラーになった行から次の処理を始めてしまい、思うように動きません。ご教示をお願いいたします。


■VBA
Sub aaa()


On Error GoTo Skip

For i = 5 To Sheets("Data").Range("D30").End(xlUp).Row


IF(～～vlookup文の処理～～) Then


'//trueかどうか表示させる
Sheets("Data").Range("H" & i) = "true"
' Sheets("Data").Range("H" & i) = "error"

End If

SuperSkip:
Next

Exit Sub

Skip:
Resume SuperSkip

End Sub
```

エクセルvbaの無限ループ処理の対処

Excel VBA について
'ここ にブレークポイントを指定して実行し、ブレークポイントで再度、実行をすると思い通りの結果になります。
F8キーを押して一行ずつ実行しても思い通りの結果になります。
ブレークポイントも何もなく通しで実行するとエラーは出ませんがシートはまっさらです。
F8キーを長押しで実行でもエラーは出ませんがシートはまっさらです。
しっかりと結果を反映するにはどうすればよいでしょうか？
お願いいたします。

Sub テスト()
Dim a As String
Dim b As Long
Dim d As Long
Dim g As Variant

Sheets("B").Select
Columns("A:B").Delete
a = 0
b = 1
d = 1

For d = 1 To 44
If d = 1 Then
a = "%E3%81%82" 'あ
ElseIf d = 2 Then
a = "%E3%81%84" 'い
ElseIf d = 3 Then
a = "%E3%81%86" 'う
ElseIf d = 4 Then
a = "%E3%81%88" 'え
ElseIf d = 5 Then
a = "%E3%81%8A" 'お
End If

    Dim objHtml As Object
    Dim objDoc As Object
    
    Set objHtml = CreateObject("MSXML2.XMLHTTP")
    
    objHtml.Open "GET", "https://www.jreast-timetable.jp/cgi-bin/st_search.cgi?rosen=&token=&50on=" & a, False
    objHtml.send
    
    Do While objHtml.readyState <> 4
        DoEvents
    Loop
    
    Set objDoc = New HTMLDocument
    objDoc.write objHtml.responseText

For Each g In objDoc.getElementsByClassName("eki")　'ここ
Cells(b, 1) = g.innerText
        b = b + 1
    Next g
    
Set htmlDoc = Nothing

Next d
End Sub

Excel VBA 手動だと問題ないが通しだとエラーは出ないが処理されない

### 前提・実現したいこと
以前、表題のことを実現するために、「該当のソースコード」の通り作ったのですが
どこかが抜け落ちてしまったため、抽出に失敗します・・・
A列には人物名があり、その人物のデータがＢ列以降に行で並んでいます。
それを、人物名で抽出し、新規シートを作り、転記して最後にその人物名にシート名を変更するという流れです。



### 発生している問題・エラーメッセージ
ここを変えろと出ます・・・
 ``` 
'変数の名前に変更
        ActiveSheet.Name = SheetNames
```

実際のシートを見ると、オートフィルタがうまくいっておらず、人物名でフィルタできていないので
見出し列だけが表示されている状態で止まっています。


### 該当のソースコード
 ```
Sub TEST4()
    'リストを、配列に格納
    Dim Data
    With Worksheets("Sheet1")
        Data = .Range(.Range("A1"), .Range("A1").End(xlDown))
    End With
    '重複しないリスト分ループ
    For i = 1 To UBound(Data, 1)
        '支店を、フィルタする
        Worksheets("Sheet1").Range("B1").AutoFilter 2, Data(i, 1)
             '別シートを追加
        Worksheets.Add
        'フィルタしたデータを、追加したシートに転記
        Worksheets("Sheet1").Range("B1").CurrentRegion.Copy ActiveSheet.Range("A1")
             '持ってきたデータ内B2の値（名前）を変数に格納
        Dim SheetNames
            SheetNames = Range("B2").Value
        '変数の名前に変更
        ActiveSheet.Name = SheetNames
       'フィルタ解除
        Worksheets("Sheet1").Range("B1").AutoFilter
    Next
    End Sub
 
```

### 試したこと
重複しないリストを作成する方法を検索してみたのですが、同じような記述で実現しているサイトが
見つからず、どうしてこれが成功していたのかわからない状態です・・・
これが間違っているのかなぁと思うのですが他の書き方がわからず・・・

```
Data = .Range(.Range("A1"), .Range("A1").End(xlDown))
```



# 補足情報（FW/ツールのバージョンなど）
office Standard 2016