常連

自己紹介

テンプレ(sheet1)と、リスト一覧(sheet2)以外は、取引先の会社名がシート名になったエクセルファイルがあります。

テンプレと、リスト一覧以外を分割して、一枚ずつに保存(保存名はシート名)して、同じ保存先に格納したいのですが、テンプレとリスト一覧のシート2枚を除いてという設定がうまくいきません。

テンプレのみ、またはリスト一覧のみを除いてだけだったらいけるのですが、、、

以下、ご教示ください。

Sub sheets_save()
For Each シート In Worksheets
If シート.Name <> "テンプレ" Then
シート.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & シート.Name
ActiveWorkbook.Close
End If
Next シート
End Sub

エクセル VBAについて

Excel のマクロで以下操作を行いたいと考えています。

シート①
|列1|列2|列3|列4|列5|列6|列7|列8|列9|列10|列11|
|:--|:--:|--:||:--|:--:|--:|
|A|B|C|D|E|F|G|H|I|J|K|
|A'|B'|C'|D'|E'|F'|G'|H'|I'|J'|K'|

シート②
|列1|列2|列3|列4|列5|
|:--|:--:|--:||:--|
|A|B|C~D|E|I|
|A'|B'|C'~D'|E'|I'|

＜前提＞
シート①が記入シートで、人間が手で入力します。
シート②はシート①に手打ちで記入されたデータの参照シートになります。
シート①には列が１１行ありますが、シート②に参照されるのはそのうち６列になります。
参照されるのは、記入されたA,B,C,D,E,Iになります。


＜やりたいこと＞
シート①で記入行が足りない場合、記入行の３行目以降を手動で行挿入し、記入します。
（シート①の２行目を手動で挿入し、A'~K'を記入するイメージ）
その際に、シート②についても**自動で行挿入を行い、該当する列の情報を参照する**ようなマクロを組みたいと考えています。
（シート②のA',B',C'~D',E',I'を自動で参照する）

なお、挿入される行数は１行とは限らないため、仮に５行挿入された場合は、５行分参照されるように出来ればと思います。

どのように行えば良いか、ご教示頂けますと幸いです。
よろしくお願い致します。

なお、C,Dは実際は時刻を表しており、C~Dは開始時刻~終了時刻となっているため１セルで２つを参照することとしていますが、
難しい場合はセルを分けて表示することも想定しています。

Excel VBA で別シートに内容をコピーしたい

### 前提・実現したいこと
フォルダ内にある10ブック（名前は全て違います）を開き
同じ行を全て削除
その後　元となるブックを開き、元ブックの2行目から4行目を
フォルダ内の10ブックの同じ行に挿入ペーストする方法を
教えてください。

削除部分までは　下記のを作成しました。その後のコピペがどうにも
わかりません。宜しくお願い致します。
Dim Myfile, Filepath As String
 Filepath = ThisWorkbook.Path & "\"
 Myfile = Dir(Filepath)
 Do While Myfile <> ""
 Workbooks.Open Filename:=Filepath & Myfile
 Workbooks(Myfile).Activate
 Worksheets(1).Rows("2:3").Select
 Selection.Delete Shift:=xlUp
 
 ActiveWorkbook.Save
 Myfile = Dir()
 Loop
 End Sub


■■な機能を実装中に以下のエラーメッセージが発生しました。

### 発生している問題・エラーメッセージ

```
エラーメッセージ
```

### 該当のソースコード

```ここに言語名を入力
ソースコード
```

### 試したこと

ここに問題に対して試したことを記載してください。

### 補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

元ブックの行を別のブック（多量のブック）の同じ行に挿入ペーストしたい

VBA初心者です。
質問させてください。

![イメージ説明](ddeca37283dabaa3065184bbd76e42b2.png)

上記のような表があり、例えば、B4に100を入力すればA2の100を検索値として
C4~F4までを自動で入力されることは可能でしょうか？

これまでVLOOKUP関数を使っていたのですが、VBAで対応したいと思っており質問させていただきました。

VBAにおいてのVLOOKUPを使った自動入力（特定のセルに検索値を入れると検索値をみて自動入力されるようにしたい）

**前提・実現したいこと**
---
行の位置はそのままに、指定した列へ移動したいです。

**発生している問題**
---
日付検索をかけると、1340行目にｶｰｿﾙを合わせていても
6行目の日付のセルに移動してしまいます。

![イメージ説明](4eea44c15d973f6082a95c50eab57102.png)

**該当のソースコード**
---
Sub 日付検索Click()

 Dim A As Range
  Dim B As Range
  Dim C As Range
    
Set A = Range("L6:MH1000").Find(what:=Range("E4").Value, SearchOrder:=xlByColumns)

If A Is Nothing Then

Else
Set B = A
Set C = A
 End If

Do
 Set A = Range("L6:MH1000").FindNext(A)
 If A.Address = B.Address Then
   Exit Do
 Else
   Set C = Union(C, A)
 End If
  Loop
C.Select

End Sub

**試したこと**
---
VBA初心者の為、Googleで検索したものをアレンジして書いています。

補足情報（FW/ツールのバージョンなど）
---
Win10、Excelは2005を利用しています。

VBAを使用して、行の位置はそのままに指定した列へ移動したいです

VBAで年間の資金繰り表を作成しています。

更新ボタンを押した際にループ処理で月ごとに値が入力されるようにしたいです。 
また、値が入力される式は作成済みなのでループで入力される際にCallで呼び出すようにしたいです。(式の名前：InputCalc)

支出・粗利益のなかの項目は増えることがあります。
iでは支出と粗利益を区別するループ、jではCallで値を入力していくループで構成を考えています。
コードの組み方がわからないので教えていただきたいです…

![イメージ説明](e7ea372ec89197a7a7a9061b689374c5.png)

```VBA
Sub Button1_Click()

With Sheets("HOME")

Dim i As Integer
Dim j As Integer

For i = 7 To .Cells(Rows.Count, 1).End(xlUp).Row


End With

End Sub 
```

VBAのループ処理書き方

ここに質問の内容を詳しく書いてください。
表題のように、Outlookと連携し会社ごとに対応した添付ファイルをつけて、一括送付するVBAを作りたいと考えています。
メール作成に必要なデータは全て一つのSheet（Contents）に記載しています。
VBA初心者でまだ理解不足が多く、どなたかお力添えいただければ幸いです。


### 発生している問題・エラーメッセージ

```
『実行時エラー 424　オブジェクトが必要です』
```

### 該当のソースコード

```ここに言語名を入力

Sub Invoice用一括メール送信マクロ2()

Dim objOutlook As outlook.Application
Dim i
Dim rowMax As Long
Dim wsMail As Worksheet
Dim objMail As outlook.MailItem

Set objOutlook = CreateObject("outlook.Application")
Set wsMail = ThisWorkbook.Sheets("Contents")

With wsList

    '送信先の件数
    rowMax = .Cells(Rows.Count, 1).End(xlUp).row

    '送信先の件数分繰り返す
    For i = 2 To rowMax
        Set objMail = objOutlook.CreateItem(olMailItem)
         objMail.To = wsMail.Cells(i, 1).Value      'メールTo宛先'
         objMail.CC = wsMail.Cells(i, 2).Value      'メールCc宛先'
         objMail.subject = wsMail.Cells(i, 3).Value 'メール件名'
         objMail.BodyFormat = olFormatPlain         'メール文頭'
         objMail.body = wsMail.Cells(i, 4).Value & vbCrLf & _
                        wsMail.Cells(i, 5).Value & " san" & vbCrLf & vbCrLf & _
                        wsMail.Cells(i, 6).Value    'メール本文'
            
    '--- 添付ファイル設定 ---'
        Dim Wm_ITEM
        Dim folder As String
        Dim FileName As String
        
        folder = wsMail.Cells(i, 7).Value
        FileAd = wsMail.Cells(i, 8).Value
        
        Wm_ITEM.Attachments.Add folder & "\" & FileName
    
    
    '--- メールの送付の実行---'
        objMail.Display
        
    Next i

    Set objOutlook = Nothing
    MsgBox "送信完了 / Send completely"

End With

End Sub


```

### 試したこと

Setを追記


### 補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

宛先ごとに対応した添付ファイルをつけて一括送付するVBA

### 前提・実現したいこと

ここに質問の内容を詳しく書いてください。

VBAのコマンドボタンを押して、数字を入れていき、999という数字が入る、または件数が100件を超えるまで入れた数字をセルA1からA2,A3 という風に入れていき、バブルソートを使って入れた数字を昇順に並び替えた後、再びセルA1からA2,A3と入れていくプログラムを作っているのですが、なぜかうまくいかないです。なので、どこをどう直したら思い通りに動いてくれるか教えてください。

### 発生している問題・エラーメッセージ

```
エラーメッセージ
```

### 該当のソースコード
VBA

Private Sub CommandButton1_Click()
Dim T As Integer
Dim num As Integer

 Do
    
    T = InputBox(" 点数を入力してください ")
    num = num + 1
    Cells(num, 1) = T 　　　　　　　' セル A1、A2、A3という風に下へ順番に点数を入れていく
    
Loop Until T = 999 Or num > 100      '999が入るか点数の入力が  100 件を超えるまで入力

If Cells(num, 1) = 999 Then
   
   Cells(num, 1).Clear
   
End If      　　　　　　　  '999 はデータに含まないので消す

Dim n As Long
n = Cells(1, 1).Cells(num, 1) 　　　　　   ' ソート対象のデータ数を特定


Dim S() As Long
ReDim S(n)     　　　　　　  ' 数列を格納する配列の準備


Dim i As Long
For i = 1 To n
   S(i) = Cells(i, 1)
Next i                  　　　　　　 ' ソート対象の数字を配列に格納


Dim x As Long
x = n - 1

Do While x > 0    　　　　    ' 隣り合う数字を比較して並び替え

   For i = 1 To x
   
      If S(i) > S(i + 1) Then
         Dim tmp As Long       　　　　' 一次変数を利用して値を入れ替える
         tmp = S(i)
         S(i) = S(i + 1)
         S(i + 1) = tmp
      
      End If
      
    Next i
    
    x = x - 1
    
Loop

For i = 1 To n
    Cells(i, 1) = S(i)
Next i                    ' ソート結果を再びセルA1、 A2 、 A3 という風に下へ順番に入れていく
      
End Sub



### 試したこと
https://vbabeginner.net/配列のソート（バブルソート）/　このURL先に書いてあるコードを参考に作ったのですがうまく動きませんでした。

### 補足情報（FW/ツールのバージョンなど）

VBA初心者なので、猿でもわかるように説明していただければ嬉しいです。

助けてください何を調べてもできないです。VBA

初学者なため思いつかず…　もしかしたら簡単なことかもしれないのですが…
ぜひ知識を与えていただきたいです…！

■やりたいこと
元データC2～4は都度内容が異なり、それを前回Saveした次の位置に転記したい。
１００行分使い切ったら元に戻って先頭から上書きさせたい。

(追記)※やりたいことの流れです※
C2,C3,C4に入力→登録→別シートA2,B2,C2へ転記→
C2,C3,C4に入力→登録→別シートA3,B3,C3列へ転記→
C2,C3,C4に入力→登録→別シートA4,B4,C4列へ転記→
                   ・・・
C2,C3,C4に入力→登録→別シートA101,B101,C101列へ転記→
C2,C3,C4に入力→登録→別シートA2,B2,C2列へ転記→

■シートについて
シート"表"とシート"入力"の二枚が存在します。

シート"表"：C2,C3,C4に値を入力する欄と登録ボタンがある
シート"入力"：セルA2~A101までの転記先となる一覧表がある

VBAでデータを別シートへ転記、途中から1行目へ戻り上書きしたい

### 前提

Excel VBA初心者です。
業務の一環で、マクロを用いて帳票作成を行うのですが、
検索をしてもなかなかヒットせず、
どなたかお力添えを頂ければと思い質問致します。


・１シートに表が１つずつあり、２シートの表を比較
・２つの表の列数は変わらず行数は可変
・A列とD列（商品コードと納品先）で一意となる

**・昨日シートと本日シートを比較して差異区分を新規シート（sheet3)にまとめたい。**
※差異区分
1.新規（本日シートにあって昨日シートにない）
2.変更（金額１）
3.変更（金額２）
4.削除(昨日にあって本日にない）



・例
sheet1「昨日シート」
商品コード/商品名/産地/納品先/金額１/金額２
A100/ りんご/青森/ 東京　/100/150
A101/青リンゴ/青森/神奈川/120/170
B150/みかん/愛媛/東京/300/500
                    ・
　　　　　　　　　　　　・
　　　　　　　　　　　　・

sheet2「本日シート」
商品コード/商品名/産地/納品先/金額１/金額２
A100/ りんご/青森/ 東京　/100/150
A101/青リンゴ/青森/神奈川/120/200
C200/マンゴー/宮崎/東京/300/500
                    ・
　　　　　　　　　　　　・
　　　　　　　　　　　　・


###　目標の作成物
新規のシートに差異一覧を表示させる。

A列に差異区分、B列以降は本日シートと同じ項目の転記

差異区分/商品コード/商品名/産地/納品先/金額１/金額２

上記の例で言うと、

差異区分/商品コード/商品名/産地/納品先/金額１/金額２
2.変更（金額２）/A101/青リンゴ/青森/神奈川/120/200
4.削除/B150/みかん/愛媛/東京/300/500
1.新規/C200/マンゴー/宮崎/東京/300/500


こんな感じで表示させたいです。


同一の表での重複検索や重複削除のページは見つかるのですが
２列で一意になる表で表が２つ、というものが見つかりませんでした。


※タブ区切りのテキストファイルが表の元データになるのですが
タブ区切りのテキストファイルをExcelのワークシートに出力するマクロを組んでいます。
いずれはテキストファイルを出力せずに比較→差分のみ抽出、としたいのですが・・・。



参考になるページだけでも構いません。
不慣れで長文になってしまい申し訳ございませんが、
何卒宜しくお願い致します。

Excel VBA 別シートの表を比較、２列で一意、差異の抽出

### 前提・実現したいこと

Excelファイルから、Excelファイルへデータを転記するExcelマクロを作成したいです。
下記ご確認いただき、知恵をお貸しいただきたいです。

**【内容】**
顧客からの問い合わせを、問い合わせ1件につき1つのExcelファイルで管理しています。
問い合わせファイル内には、問い合わせの内容・対応した内容・対応日などを記載しており、問い合わせファイルは対応のステータス毎（未対応、対応中、対応完了）にフォルダを分けて管理しています。
3つのフォルダに別れた全ての問い合わせファイルを、以下条件の元、一覧として作成するマクロを作成したいです。（集計などを行うために一覧にしたいです）

-----

**【前提条件】**
1. 一覧ファイル（マクロブック）は、未対応フォルダ、対応中フォルダ、対応完了フォルダと同フォルダ内にある。
─┬─ 一覧ファイル
''''├─ 未対応フォルダ
''''├─ 対応中フォルダ
''''└─ 対応完了フォルダ

2. 一覧ファイルへは、問い合わせファイルを1レコードとし、ファイル内すべての内容（問い合わせ内容・対応内容・対応日など）を転記する。
※一覧ファイルのB列～BM列に64このデータを転記する。A列は、レコードの1件目から順に自動で番号を採番する。）
※また一覧ファイルの11行目までは、タイトル行としているため、12行目から転記を始める。

3. 一覧ファイルの特定のカラム（AQ列：対応完了日）が空白でない場合（対応が完了している）は、該当する問い合わせファイルから転記は行わず、
AQ列が空白の場合（対応が完了していない）のみ、該当する問い合わせファイルから転記を行う。（処理時間短縮のため）

4. 問い合わせファイルは、日に日に新規で追加される。

5. 処理効率化のため、データを転記する際は、配列を利用したい。


**【補足】**
問い合わせファイルのファイル名は一意であり、ファイル名は、「◯_aaa.xlsx」となっています。
aaa（以下、管理番号と呼ぶ）の部分は、問い合わせファイル内のセルを参照しており、一覧に転記した場合、管理番号は一覧ファイルのD列に転記される。

-----
**【作成したソースコード概要】**

① 一覧のAQ列が空白ではない（対応が完了してる）レコードの管理番号を取得する
② 一覧からAQ列が空白（対応が完了していない）レコードをクリアする
③ 問い合わせがファイルのパスを取得する
④ ①で取得した管理番号をキーに、問い合わせファイルのファイル名の一部（管理番号の部分）と一致しない場合、⑤の処理を実行
⑤ 問い合わせファイルを開いて、データを一覧に転記する
⑥ 作成した一覧を、ソート、リファレンスナンバーを採番


----
上記イメージでソースコードを作成しようと思っていますが、ソースコード作成のアドバイスや、配列に格納して転記する方法もご教示いただければと思います。
エンジニアではないため拙い部分のあり、また最近VBA独学で勉強しているため基本を理解していないところもあるかもしれませんが、ご了承ください。
宜しくお願い致します。

### 発生している問題・エラーメッセージ

```
作成した下記ソースコードでは、★の箇所で「インデックスが有効範囲にありません」とエラーになります。
他に下記ソースコードに問題がある場合も、ご指摘いただければ幸いです。

```

### 該当のソースコード

```VBA
Option Explicit

    Dim intRet      As Integer
    Dim wb          As Workbook
    Dim ws          As Worksheet
    Dim rng        As Range
    Dim finNum()   As Variant    '対応完了の管理番号
    Dim nyNum()    As Variant    '対応未完了の管理番号
    Dim i           As Integer    '対応完了の配列変数
    Dim j           As Integer    '対応未完了の配列変数
    Dim num         As Variant
    Dim file        As Object
    Dim cnt         As Integer

    Public Sub 一覧作成()

        '処理時間計測用変数
        Dim starttime As Double
        Dim endtime As Double
        Dim processtime As Double

        '一覧作成の実行確認
        intRet = MsgBox("表を最新の状態にします。よろしいですか？", vbOKCancel, "確認")
        If intRet <> vbOK Then
            Exit Sub
        End If

        '開始時間取得
        starttime = Timer

        '画面更新を停止
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
        End With

        'シートの非表示行を表示する
        Cells.EntireColumn.Hidden = False

        Set wb = ActiveWorkbook
        Set ws = ActiveSheet

        '一覧にある管理NOを取得する
        For Each rng In ws.Range("AQ12", ws.Cells(ws.Rows.Count, "AQ").End(xlUp))
            If ws.Cells(rng.row, 43) <> "" Then
                For i = LBound(finNum) To UBound(finNum) '/★ここで上記エラーになります
                    finNum(i) = ws.Cells(rng.row, 4)
                Next
'            ElseIf ws.Cells(rng.row, 43) = "" Then
'                For j = LBound(nyNum) To UBound(nyNum)
'                    nyNum(j) = ws.Cells(rng.row, 4)
'                Next
            End If
        Next

        '対応完了日（AQ列）が空白の行の値をクリアする
        Dim rw As Integer
        For Each rng In ws.Range("AQ12", ws.Cells(ws.Rows.Count, "AQ").End(xlUp))
            If ws.Cells(rng.row, 43) = "" Then
                rw = ws.Cells(rng.row, 43).row
                Rows(rw).ClearContents
            End If
        Next

        '問い合わせファイルのパスを取得
        Dim Fld()        As String
        Dim a            As Integer
        Dim fso          As Object 'FileSystemObject
        Dim BaseNames()  As String
        Dim Names()      As String
        Dim intPos       As Integer

        Const strDefFild As String = "問合票"

        Fld(0) = wb.Path & "\10 未対応"
        Fld(1) = wb.Path & "\20 対応中"
        Fld(2) = wb.Path & "\30 対応済み"

        Set fso = CreateObject("Scripting.FileSystemObject")
        For a = 0 To 2
            For Each file In fso.GetFolder(Fld(a)).Files
                cnt = cnt + 1
                BaseNames(cnt) = fso.GetBaseName(file.Name)
                intPos = InStr(BaseNames(cnt), strDefFild)
                Names(cnt) = Mid(BaseNames(cnt), intPos + 2)
                '対応完了以外の問合票ファイルを一覧へ取り込み（対応未完了 + 新規）
                If Names(cnt) <> finNum(i) Then
                    Call 取り込み
                End If
            Next
        Next

        Call 項番採番

        '終了時間取得
        endtime = Timer

        '処理時間取得
        processtime = endtime - starttime

        Range("A3").Select

        MsgBox "一覧作成しました。" & "（処理時間：" & processtime & "秒）"

        '画面更新を再開
        With Application
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
            .ScreenUpdating = True
        End With

    End Sub

    '★問合票ファイルを一覧へ取り込み
    Public Sub 取り込み()
        Dim row As Integer
        Dim clm As Variant
        Dim s   As Worksheet

        For row = 12 To cnt
            For Each clm In ws.Range("A11", s.Cells(11, s.Columns.Count).End(xlToLeft))
                With Workbooks.Open(file.Path, UpdateLinks:=False, ReadOnly:=True)
                    Set s = .Sheets("問い合わせ一覧票")
                    file.Cells(row, clm).Value = s.Cells(10, 33).Value

		　　（文字数の関係により省略）

                    file.Cells(row, clm).Value = s.Cells(2, 45).Value
                    file.Cells(row, clm).Value = s.Cells(2, 46).Value
                End With
            Next clm
        Next
    End Sub

    '作成した一覧をソート、項番採番
    Sub 項番採番()

        Dim L As Integer
        Dim n As Integer

        Set wb = ActiveWorkbook
        Set ws = ActiveSheet

        'ソート
        Range("A12", ws.Cells(ws.Rows.Count, "D").End(xlUp).Offset(0, -3)).Select
        Selection.Sort Key1:=Range("D12"), Order1:=xlAscending, _
                       Key2:=Range("E12"), Order2:=xlAscending, Header:=xlYes, _
                       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin

        '番号付け
        L = 12
        n = 1

        While wb.ws.Cells(L, 4).Value <> ""
            wb.ws.Cells(L, 1).Value = n
            L = L + 1
            n = n + 1
        Wend
    End Sub

```


### 補足情報（FW/ツールのバージョンなど）

Excel2016

VBAマクロ　大量Excelファイルのデータ転記

エクセルのマクロについて教えて下さい。

エクセルマクロ（VBA）初心者です。

今回、勤怠管理の自動化をしたいと思っています。
現在ファイルAのデータをファイルBに転記する作業を手動で行っています。
詳細は添付画像をご覧ください。

これをマクロでやろうと思っているのですが、
1 ファイルAのD列の日付をファイルBのA列から探す。
2 日付があった場合（例えば4日）、ファイルAの4日のE列、F列のデータを
　ファイルBのD列、E列に転記


![イメージ説明](aa83aa2700a4fee2ebec527a9ed48c4c.png)

という動きにしようと考えているのですが、そもそもこの動きはマクロで可能でしょうか？
可能な場合、記述の仕方を教えて頂けると幸いです（ざっくりでも結構です）

もし、もっといいやり方があれば教えて下さい。

宜しくお願いします。

エクセルマクロについて

ブックの名前を変更するマクロの作り方を教えていただけませんでしょうか？

現在ワークシート上にコンボボックスがあり、そこにブック名にしたい候補の一覧があります。
選んだものをブック名にしたい場合はどのようにしたらよろしいのでしょうか？

ブック名をセルに反映させることはできたのですが、その逆ができません。


よろしくお願いいたします。

ブック名を変更したい

**表形式のデータをVBAで整列したい**

![イメージ説明](1006d7f99973e3b48c2f5e4ed6bb0369.png)

画像の左側のような表を右側のように整列したいです。
VBAの「配列」を使えばできるのではないかと考えているのですが、
どこを配列して、どこをループすればいいのかの考え方から分からずつまづいています。。。

VBA初心者で不躾な質問かと思いますが、
ご教授いただければ嬉しいです！！！

宜しくお願いいたします。

Excelの表形式のデータをVBAで整列したい

いつもお世話になっております。
ExcelVBAで、簡単な処理をしたいのですがマクロがあるためか、なぜかうまくいかず困っております。
また、エラーについても解決方法を色々とググったのですがなかなか見つからず、それでテラテイルに聞きました。よろしくお願いいたします。

### 【やりたいこと】

マクロを含むブックの特定のシートを（マクロなしで）新規ブックに保存したい

### 問題点
新規ブックに保存はできたが、デバッグ中、よく見るとマクロ実行中の名前が新規ブックの名前になっている。
![イメージ説明](1f1a36a6578503042738be99493f5c88.png)
![イメージ説明](dbb1a99a401fadc1ab6b47534c7aae99.png)
更に、この状態でデバッグをしながらコードを修正しても元のブックに保存されない。

しかし、実行後出来上がった新規ブックを確認すると、マクロは存在していません。
更に、修正したはずのマクロも元ファイルにも保存されていません。

これではデバッグしながら修正ができないのですが、何か良い方法はありますでしょうか？

### 他の方法
色々とググってみると、「SaveAs」ではなく「SaveCopyAs」の方がいいという書き込みもありました。
しかし、その方法だと「メソッドまたはデータメンバが見つかりません」と出ます。
![イメージ説明](627cb078e8bdf9e168847627586a9946.png)
SaveCopyAsの構文は、
「Workbookオブジェクト.SaveCopyAs (フルパス＋ファイル名)
なので、「filename」にフルパス名とファイル名を格納したものを使ったのですが・・。

何かほかに良い方法はありますでしょうか？
また、同じような経験をしておられる方はいますでしょうか？

すみませんが、知恵をお貸しください。
よろしくお願いいたします。

ExcelVBAでマクロを含むブック内の特定のシートをコピーすると特定のシートにマクロがうつってしまう

###前提・実現したいこと

フォルダーにExcelデータが複数あり（タイトル・データ1列のみ）
このExcelデータを一つのExcel（マクロ付Excel)にまとめるシステムをVBAにて作成しています。
複数エクセルは、縦型ですがまとめるにあたり横型データに
変換していきたいです。
初心者で、手探り状態で進めています。ご教授頂ける
方がいまたらよろしくお願いします。

###発生している問題・エラーメッセージ

過去にでた文章を張り付けて修正していますが
なかなか上手く作動しません。

###該当のソースコード
###試したこと
Sub データ蓄積3()

Dim Bk As Workbook
 Dim Rw As Long, ERw As Long
 Const ShName = "Sheet1"
 'Const PathN = "各ブックのパス名" 
Const FNCom = "問診票" ' <-- ファイル名の先頭共通部分指定
Dim FileN As String
 Dim Cnt As Integer
 FileN = Dir(PathN & FNCom & "*.xlsx") ' <-- 拡張子を指定
Rw = 1
 Application.ScreenUpdating = False
 Do Until FileN = ""
 Cnt = Cnt + 1
 Set Bk = Workbooks.Open(PathN & FileN, ReadOnly:=True)
 With ThisWorkbook.Sheets(ShName)
 
  Sheets("Sheet2").Select
 If Cnt = 1 Then
' .Cells.Clear
 Rows("2:2").Select
    Selection.Copy
    Windows("問診蓄積データ.xlsm").Activate
    Range("A2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'ShName.Close

' Bk.Sheets(2).Cells.Copy .Range("A2")
' .Rows(2).Insert
' .Range("A2").Value = FileN
' .Columns(1).AutoFit
 
 Else
     Windows("問診蓄積データ.xlsm").Activate

 Rw = .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
 .Cells(Rw, 1).Value = FileN
  
 ERw = Bk.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
 If ERw > 1 Then Bk.Sheets(2).Range("A" & ERw & ":AG
Windows(FileN).Activate
" & ERw).Copy .Cells(Rw + 1, 1)
 End If
 Bk.Close
 End With
 FileN = Dir
 Loop
 Application.ScreenUpdating = True
 MsgBox Cnt & " 個のブックのデータを集合しました。", vbInformation
 Set Bk = Nothing
 End Sub



###補足情報(言語/FW/ツール等のバージョンなど)
より詳細な情報

複数Excelを一つにまとめる方法

ExcelのVBAでシートへのデータの表示を行っています。

１つ目のSQLはIDとNameを取得しています。
２つ目のSQLはIDとresultを取得しています。

SQLの取得する条件(where句以降)が異なるので別々で取得しないといけないと思っております。また、２つ目のSQLはIDは同じでもresultが異なる複数のデータが取得できています。


１つ目のSQLで取得したデータはそのままExcelのシートに表示しています。


２つ目のSQLを投げた際に１つ目のSQLの中のIDと紐づくデータのみ１つ目のSQLで表示したExcelの行に横につなげたいと思っています。
そこで１つ目のSQLのIDと２つ目のSQLのIDを取得してチェックを行いたいのですが、実装方法が分かりません。
以下実装方法です。

```VBA
Set myCon = New ADODB.Connection
myCon.Open　DSN=DB接続情報

・１つ目のSQL
SQL = "SELECT ID, NAME FROM test INNER JOIN ~~ WHERE ~~"
～～～ExcelシートのB行にID、C行にNameの書き込みの処理～～～


・２つ目のSQL
Dim SQL As String
Set myRS2 = New ADODB.Recordset
SQL = "SELECT ID, RESULT FROM test INNER JOIN ~~ WHERE ~~ "
myRS2.ActiveConnection = myCon
myRS2.Source = SQL
  
Range("B2").Select

以下の記述方法が分からない。

```


恐らくB行のデータを空の行までループして値を取得→１つ目のSQLで取得しB行に表示されているIDを２つ目のSQLで取得したIDが同一かのチェックの実装→同一であれば紐づいたIDと同じ行にデータを繋げる
の実装かなとは思っています。

２つ目のSELECT文実行時の取得されるデータ
|ID|result|
|:--:|--:|
|200|AAA|
|200|BBB|


１つ目のSELECT文実行後のExcelシート
|A|B(ID)|C(name)|
|:--|:--:|--:|
|1|100|test|
|2|111|data|
|3|200|aaa|


完成イメージ図
|A|B(ID)|C(name)|D(result)|
|:--|:--:|--:|
|1|100|test||
|2|111|data||
|3|200|aaa|AAA|
|3|200|aaa|BBB|


追記
DBはPostgresです。
完成イメージ図のAの３の行はA,B,Cはセル結合されるものであり、Dのみ単体です。

VBAで複数のSQLの結果を繋げたい

ユーザーフォームのRefEditからセル範囲を指定し、ユーザーフォームのテキストボックスの文字を、複数ブックに設定したいと考えています。
Sub test()
    Dim filePath As Variant
    Dim i As Long
    Dim WB As Workbook
    
    filePath = Application.GetOpenFilename( _
        FileFilter:="Excelブック(*.xlsx;*.xlsm),*.xlsx;*.xlsm", MultiSelect:=True)
    
    If IsArray(filePath) Then
    For i = LBound(filePath) To UBound(filePath)
    Set WB = Workbooks.Open(filePath(i))
    Dim Ref As Range
    Set Ref = Range(RefEdit1.Value)
    Ref.Value = TextBox1
    Next
    End If
End Sub

上記は変数RefEditとTextBoxの宣言をしていません。
Private sub は別モジュールに戻り値を渡すことができないようなので困っています
なにかいい方法はないでしょうか

また、フォーム等にはこだわっておらず、とにかく指定したセル範囲に任意の文字を複数ブックに設定できればと考えています。

学び始めて1週間目なので、変なことを言ってるかもしれませんが、ご容赦ください。


言葉足らずで申し訳ありません。
上記ではフォームにこだわらないとは書いてますが、誤りでした。
マクロに触れたことのない方が操作できるマクロを作りたいと思っています。

選択ダイアロｸﾞでエクセルファイルを開き、フォーム等でセル範囲を指定して、テキストボックスに打ち込まれたテキストを、すべてのブックに処理したいと思っています。

ヒントだけでも構わないので、ご教授願います。

VBAで複数ブックの指定したセル範囲に任意の文字を同一処理したい。

お世話になります。詰まっており頭を抱えております。何卒ご教示頂けますでしょうか。

ブックA シート１のC列１０行目から数字のリストがあります。### ヘディングのテキスト

そのC列から先頭４文字を参照して、ブックB シート1 A列の４桁の数字と照らし合わせ、４桁が合致した時に、隣のB列にある商品名をブックAのA列１０行目に反映して行きたいと考えています。

しかしブックA シート１のC列１０行目からの数字のリストは

988436024665
3038404020176
35402010538
3038403029003
2403055449

上記のように９桁～１３桁となっており、

９桁の場合は先頭に０を４個、１０桁の場合は０を３個、１１桁の場合は先頭に０を２個、１２桁の場合は先頭に０を１個つけることで、１３桁にし、４桁を抽出するようにしたいと考えております。!

丸投げと言われても、仰るとおりで恐縮ですが、アドバイス、ヒントなどご教示頂けましたら幸いです。

よろしくお願い申し上げます。

[ブック](f4e95a44b9581893ed2986886dd4469f.jpeg)

9～13桁の数字が並んだリストを別ブックにある数字と商品を参照して、本来のブックに反映させたいです。

### 実現したいこと
ファルダを選択してそのフォルダ内にあるファイルのファイル名/ファイルパス/更新日/ブックのページ数を取得したい

### 発生している問題・エラーメッセージ

```
オブジェクトはこのプロパティまたは、メソッドをサポートしていません
```

### 該当のソースコード

```ここに言語名を入力
Sub pagecount()
    Dim selectFolder As Variant
    Dim i As Long
    Dim sfile As Variant
    Dim objsheet As Worksheet
    
    Application.ScreenUpdating = False
    
    Row = 2
    col = 2
    i = 1

    With Application.FileDialog(msoFileDialogFolderPicker)
       If .Show = True Then
       selectFolder = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
       Set fso = CreateObject("Scripting.FileSystemObject")
       Set sfile = fso.GetFolder(selectFolder)
       Set objsheet = sfile.PageSetup.pages.Count              
       
　　　　For Each file In sfile.files
           Cells(Row + i, col) = file.path
           Cells(Row + i, col + 1) = file.Name
           Cells(Row + i, col + 2) = file.DateLastModified
　　　　　　Cells(Row + i, col + 3) =
           i = i + 1
        Next
     　End If
   End With
End Sub

```

### 分からないこと

ファイル名/ファイルパス/更新日を取得することはできたのですがページ数だけが実装でないです
Set sfile = fso.GetFolder(selectFolder)で取得したブックのページ数を取得すにはどうしたらいいのか。VBAに関してまだ学習不足だと痛感しているのですがご教授いただければ幸いです。

### 補足情報（FW/ツールのバージョンなど）

Excel2010