Sub 取り込み()
Dim myPath As String, myName As String
Dim twb As Workbook, ws As Worksheet
Dim OpenFileName As String
With ThisWorkbook

ChDir ThisWorkbook.Path & "\data\"
OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls")
If OpenFileName = "False" Then Exit Sub
myName = Dir(OpenFileName)
Workbooks.Open OpenFileName
For Each ws In Worksheets
If SheetCopyFLG(ws) Then 'ここにあるのですが
ws.Copy after:=.Worksheets(.Worksheets.Count)

End If
Next ws
Workbooks(myName).Close
End With
End Sub

'-------------------------------------------------------------
Function SheetCopyFLG(tws As Worksheet) As Boolean 'ここをエラーと指す
Dim ws As Worksheet
SheetCopyFLG = True
For Each ws In ThisWorkbook.Worksheets
If tws.Name = ws.Name Then
If MsgBox(tws.Name & "は存在します。コピーしますか?", _
vbYesNo + vbExclamation, "SheetCopy") <> vbYes Then
SheetCopyFLG = False
End If
Exit Function
End If
Next ws
End Function
 
マクロ自体は動くのですが、ブックを起動時にvbaの画面になりコンパイルエラー
オートメーションエラーです
致命的なエラーです
とでます、どうしてでしょうか。
bvaを閉じマクロ実行すると問題なく実行します。

A 回答 (2件)

>オートメーションエラーです



Sub 取り込み()
With ThisWorkbook
となっていて、
For Each ws In Worksheets 'オープンしたシートを
'以下でループさせて、

Function SheetCopyFLG(tws As Worksheet)
For Each ws In ThisWorkbook.Worksheets

エラーの直接の原因は分かってはいませんが、こちらで、そのパラメータのtwsを捨てるかどうか、対話型にしているわけですが、そういう、ループのオブジェクト型の変数を、そのまま外のコードに渡すのはうまくないと思います。

If tws.Name = ws.Name Then

やっていることは文字比較なのですから、最初から、文字列で渡せばよいわけです。

Sub 取り込み()
For Each ws In twb.Worksheets
If SheetCopyFLG(ws.Name) Then
'--------------------
Function SheetCopyFLG(shName As String) As Boolean '文字列で渡す
 Dim ws As Worksheet
  For Each ws In ThisWorkbook.Worksheets
  If UCase(shName) = UCase(ws.Name) Then '文字列比較
   If MsgBox(shName & "は存在します。コピーしますか?", _
        vbYesNo + vbExclamation, "SheetCopy") <> vbYes Then
    SheetCopyFLG = False
    Exit Function
   Else
    SheetCopyFLG = True
    Exit Function
   End If
  End If
 Next ws
 SheetCopyFLG = True
End Function

しかし、私なら、例えば、裏技的ですが、このように、dummy(dumm) を使って、オブジェクトが取れるなら、シートがある、オブジェクトがないなら、シートはないということも可能です。

For Each ws In twb.Worksheets
    On Error Resume Next
    Set dumm = .Worksheets(ws.Name)
    If IsEmpty(dumm) = False Then
     If MsgBox("同じシート名があります。" & ws.Name & vbCrLf & _
     "コピーしますか?", vbOKCancel) = vbOK Then
      ws.Copy after:=.Worksheets(.Worksheets.Count)
     End If
    Else
     ws.Copy after:=.Worksheets(.Worksheets.Count)
    End If
    dumm = Empty 'Variant 型の空の値
    On Error GoTo 0
   Next
   twb.Close False
   End If
  Next
    • good
    • 0
この回答へのお礼

ありがとう御座います。勉強になります。

お礼日時:2017/06/17 08:25
    • good
    • 0
この回答へのお礼

ありがとう勉強します

お礼日時:2017/06/17 08:23

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aと関連する良く見られている質問

Q勉強中 bva

取り込むブックのホルダーにあるブックを選べないその下の階層\dataホルダーから選びたいのですが
選んでコピーしてコピーしたブックは閉じたいのですが、Workbooks.Closeどこに入れてもエラーになります。教えて下さい

Sub 取り込み()
Dim myPath As String, myName As String
Dim twb As Workbook, ws As Worksheet
With ThisWorkbook
myPath = .Path & "\"
myName = Dir(myPath & "*.xls", vbNormal)
If myName <> .Name Then
Set twb = OpenBook(myPath & myName)
If Not twb Is Nothing Then
For Each ws In twb.Worksheets
If SheetCopyFLG(ws) Then
ws.Copy after:=.Worksheets(.Worksheets.Count)
End If
Next ws
End If
End If
End With
End Sub
'-------------------------------------------------------------
Function OpenBook(myName As String) As Workbook
Dim wb As Workbook
Set OpenBook = Nothing
For Each wb In Workbooks
If LCase(wb.FullName) = LCase(myName) Then
Set OpenBook = wb
Exit For
End If
Next wb
If OpenBook Is Nothing Then
On Error Resume Next
Set OpenBook = Workbooks.Open(myName)
End If
End Function
'-------------------------------------------------------------
Function SheetCopyFLG(tws As Worksheet) As Boolean
Dim ws As Worksheet
SheetCopyFLG = True
For Each ws In ThisWorkbook.Worksheets
If tws.Name = ws.Name Then
If MsgBox(tws.Name & "は存在します。コピーしますか?", _
vbYesNo + vbExclamation, "SheetCopy") <> vbYes Then
SheetCopyFLG = False
End If
Exit Function
End If
Next ws
End Function

取り込むブックのホルダーにあるブックを選べないその下の階層\dataホルダーから選びたいのですが
選んでコピーしてコピーしたブックは閉じたいのですが、Workbooks.Closeどこに入れてもエラーになります。教えて下さい

Sub 取り込み()
Dim myPath As String, myName As String
Dim twb As Workbook, ws As Worksheet
With ThisWorkbook
myPath = .Path & "\"
myName = Dir(myPath & "*.xls", vbNormal)
If myName <> .Name Then
Set twb = OpenBook(myPath & myName)
If Not twb Is Nothing Then
Fo...続きを読む

Aベストアンサー

組み込むならいかのようになります。
------------------------------------------------
Sub 取り込み()
Dim myPath As String, myName As String
Dim twb As Workbook, ws As Worksheet
With ThisWorkbook
Dim OpenFileName As String
ChDir ThisWorkbook.Path & "\data\"
OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls")
If OpenFileName = "False" Then Exit Sub
myName = Dir(OpenFileName)
Workbooks.Open OpenFileName
For Each ws In Worksheets
If SheetCopyFLG(ws) Then
ws.Copy after:=.Worksheets(.Worksheets.Count)
End If
Next ws
Workbooks(myName).Close
End With
End Sub
------------------------------------------
ChDir ThisWorkbook.Path & "\data\"
は、不要ならコメントアウトしてください。

組み込むならいかのようになります。
------------------------------------------------
Sub 取り込み()
Dim myPath As String, myName As String
Dim twb As Workbook, ws As Worksheet
With ThisWorkbook
Dim OpenFileName As String
ChDir ThisWorkbook.Path & "\data\"
OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls")
If OpenFileName = "False" Then Exit Sub
myName = Dir(OpenFileName)
Workbooks.Open OpenFileName
For Each ws In Worksheets...続きを読む

Q下記のようなタグの場合、VBAでボタンをクリックするためにはどのような処理になるのでしょうか? TY

下記のようなタグの場合、VBAでボタンをクリックするためにはどのような処理になるのでしょうか?
TYPE=”button” や TYPE=”submit”の場合は、処理例があるのでわかるのですが・・・
--------------
<div id="btn_login">

<!--
<a href="./login/login_new.htm?height=200&width=370" rel="sexylightbox" ><img src="images/btn_login_off.png" class="iepngfix"></a>
-->

<!--
<a href="./login/login_new.htm?height=200&width=370" rel="sexylightbox" ><img src="images/btn_login_off.png" class="iepngfix" onClick="JavaScript:document.frmDefault.hdnKushituSearchFlg.value=;"></a>
-->

<!--
<a href="./login/login_new.htm?TB_iframe=true&#038;height=190&#038;width=370" class="lightbox" rel="sexylightbox"><img src="images/btn_login_off.png" class="iepngfix" onClick="JavaScript:document.frmDefault.hdnKushituSearchFlg.value=;"></a>
-->
<a href="./login/login_new.htm?height=200&width=370" rel="sexylightbox" ><img src="images/btn_login_off.png" class="iepngfix" onClick="JavaScript:document.frmDefault.hdnKushituSearchFlg.value=0;"></a>

</div><!--btn_login-->

下記のようなタグの場合、VBAでボタンをクリックするためにはどのような処理になるのでしょうか?
TYPE=”button” や TYPE=”submit”の場合は、処理例があるのでわかるのですが・・・
--------------
<div id="btn_login">

<!--
<a href="./login/login_new.htm?height=200&width=370" rel="sexylightbox" ><img src="images/btn_login_off.png" class="iepngfix"></a>
-->

<!--
<a href="./login/login_new.htm?height=200&width=370" rel="sexylightbox" ><img src="images/btn_login_off.png" class="iep...続きを読む

Aベストアンサー

ANo1です。

>getElelentsByTagName("img")
エラーメッセージ通りで、存在しないメソッドだから。

VBAのインデックスの開始がよくわかっておりませんが、もしかすると、インデックスは「1」かもしれませんので、両方テストしてみてください。

QVBA、マクロについて、どなたか知恵をお貸し願います!

VBA独学中の初心者です。
ある問題に躓いており、どうしても動かない部分があるため、皆様のお力添えをいただきたいです。
説明が稚拙で分かりづらいかもしれませんが、宜しくお願いいたします。

① 2つのbook(book1/book2)があるとし、登録したマクロはbook2に設置する。
book2のsheet2に以下のような表を作る。
 ※枠線がズレてしまっていますが、それぞれが1つのセルと考えてください。
  人物・情報と入力されたセルは見出しです。
  また、1人の人物のデータに対し、その人の情報が3つあるとします。
  
______________
|人物   |   情報   |
_______________

|B君 |  |  |  |
_______________
|C君   | | | |
_______________
|A君 | | | |
_______________


② book1のsheet3に、同じ表があるとする。ただし、情報のセルは記入されている。
 
________________
|人物   |   情報     |
_______________

|A君 |長男|中学生|14歳|
_______________
|B君   |次男|小学生|10歳|
_______________
|C君 |長男|高校生|16歳|
_______________

③book2に設置しているマクロを実行すると、book1/sheet3のデータを読み込み、book2/sheet2の該当する人物のデータに表示されるようにする。但し、①②をみてわかるように、人物の名前の順番は同じではない。



・・・というものです。
最初に作ったプログラムでは、以下のように考えました。

book1/sheet3のUsedRangeから”A君”という文字列を

Set A君1 = Cells.Find(what:="A君", lookat:=xlPart)
で探し、
Selection.Offset(Columnoffset:=1).Select
で1つとなりのセルをActiveにし、
そのActivecellを"A君情報1"という変数にし、Do loopを使ってbook1/sheet3の"情報"セルがが空白になるまで1つずつ右に移動/変数を設定し、その値をbook2/sheet2の該当セルに代入していく・・・・(book2/sheet2の表からも、同じ工程で"A君"を探し、隣のセルに変数を設定する)というものです。そして、C君までの情報を全て出力し終えるというプログラムを作りたいのです。

ちなみに、book2からbook1の呼び出しはできました。

以下が作ってみたプログラムです。↓




'型があっていないとエラーになるため、とりあえずすべてVariant型にしています
Dim SorceFile As Variant, OpenFile As Variant
Dim A君1 As Variant, B君1 As Variant, C君1 As Variant
Dim A君情報1 As Variant, B君情報1 As Variant, C君情報1 As Variant
Dim A君情報2 As Variant, B君情報2 As Variant, C君情報2 As Variant

'現在開いているbook2の名前をSorceFileという変数にする
Set SorceFile = ThisWorkbook
'ファイル(book1)を選択して開く
OpenFile = Application.GetOpenFilename
If OpenFile <> fales Then
Filename = Dir(OpenFile)
MsgBox Filename
Workbooks.Open OpenFile
Else
MsgBox "キャンセルされました"
End If

'開いたファイル(book1)から、"A君"という文字列を探す。見つかったら、1つ隣のセルに移動し、"A君情報1"という変数を設定する。
ActiveSheet.UsedRange.Select
Set A君1 = Cells.Find(what:="A君", lookat:=xlPart)
A君1.Select
A君1.Offset(columnoffset:=1).Select
A君情報1 = ActiveCell

'マクロが設置されているbook2をアクティブにし、同様に"A君"という文字列を探す。見つかったら、1つ隣のセル(空白)に移動し、その空白のセルに"A君情報2"という変数を設定する。
ThisWorkbook.Activate
ActiveSheet.UsedRange.Select
Set A君2 = Cells.Find(what:="A君", lookat:=xlPart)
A君2.Select
A君2.Offset(columnoffset:=1).Select
A君情報2 = ActiveCell




・・・と、ここまではステップインをしながら変数の値を確認できています。、
このあとbook2の空白のセル"A君情報2"にbook1の"A君情報1"の値を代入したいのですが、

ThisWorkbook.Worksheets("sheet2").A君情報2.value = Workbooks(SorceFile).Worksheet("sheet1").A君情報1.value

↑ではコンパイルエラーになります。book2の表、A君の空白の情報で"長男"~"14歳"まで、book1から抽出/出力ができたら、次はB君C君・・・としていきたいのですが、「型が一致しない」や「インデックスが有効範囲にありません」となってしまいます。
この値だけ代入することができれば、私の力でもプログラムを最後まで作成することができるのですが・・・

分かりづらく、しかも玄人の方からすれば何だこのマクロは!!となるかもしれませんが、
どうかアドバイスの程、宜しくお願いいたします。

VBA独学中の初心者です。
ある問題に躓いており、どうしても動かない部分があるため、皆様のお力添えをいただきたいです。
説明が稚拙で分かりづらいかもしれませんが、宜しくお願いいたします。

① 2つのbook(book1/book2)があるとし、登録したマクロはbook2に設置する。
book2のsheet2に以下のような表を作る。
 ※枠線がズレてしまっていますが、それぞれが1つのセルと考えてください。
  人物・情報と入力されたセルは見出しです。
  また、1人の人物のデータに対し、その人の情報が3つあると...続きを読む

Aベストアンサー

こんばんは。

要するに、ソースファイル(データファイル)から情報を取り出す内容なのですね。
それをあえてFind メソッド指定なのかな?

>ActiveSheet.UsedRange.Select
だったら、以下は、Cells ではなくて、Selection でしょうね。

> Cells.Find(what:="A君", lookat:=xlPart)
なぜ、xlPart になっているのでしょうか?表記の乱れがあるということでしょうか?
変数の使い方とか、初歩的なところがまだ出来ていません。

>玄人の方からすれば何だこのマクロは
Findメソッド は、常連さんの某氏の専売特許のようなものですが、私だと、配列からMatch関数を利用しいるのだろうとは思います。玄人的なら、ADODBでしょう。ファイルを直接開けないで可能だからです。もちろん、Excel関数での処理もありますが、あまり格好がよくありません。

私が書くと、こんなコードにしてしまいます。

person info1 info2 info3
A君 長男 中学生 14歳
B君 次男 小学生 10歳
C君 長男 高校生 16歳
D君 三男 大学生 18歳 * 新たな情報が加わった場合も、D君のものだけを取るようにしています。

一旦取得した後に、D君の資料を取り寄せる
B君 次男 小学生 10歳
C君 長男 高校生 16歳
A君 長男 中学生 14歳 
D君 



'//標準モジュール
Sub GetDataAll()
 Dim wb1 As Workbook 'データのソースファイル
 Dim AcSh As Worksheet 'アクティブシート(データを受け取る側)
 Dim c As Range
 Dim r As Range
 Dim startRw As Long '検索文字列の最初の行
 Dim FindArea As Range 'データ・ソースの被検索場所
 Const FNAME As String = "myDATABook.xlsx" 'Thisbook と同フォルダーのファイル名
 Set AcSh = ThisWorkbook.Worksheets("Sheet2")
 
 On Error GoTo ErrHandler
 Set wb1 = Workbooks(FNAME) 'オブジェクトとして認識できるか?できなければ、ErrHandlerに飛ぶ
 
 Set FindArea = wb1.Worksheets("Sheet1").Columns(1) 'ソースファイルの1列目を検索
 With AcSh
  Application.Goto AcSh.Range("A1") 'データをインポートするシートに戻る

  'データに空きがないか調べ、データ検索の初期値の行を求める
  If .Cells(Rows.Count, 1).End(xlUp).Row > .Cells(Rows.Count, _
    2).End(xlUp).Row Then
    startRw = .Cells(Rows.Count, 2).End(xlUp).Row + 1
  Else
    MsgBox "データの取得の必要がありません。", vbExclamation
    Exit Sub
  End If
  
  '単語検索は、ワイルドカードを加える, c.Value & "*" ->LookAt:=xlWhole となる
  For Each c In .Range(.Cells(startRw, 1), .Cells(Rows.Count, 1).End(xlUp))
   If c.Value <> "" Then
    Set r = FindArea.Find(What:=c.Value & "*", LookIn:=xlValues, _
      LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, _
      MatchByte:=False)
    If Not r Is Nothing Then
     '配列の受け渡し(非推奨)
     c.Offset(, 1).Resize(, 3).Value = r.Offset(, 1).Resize(, 3).Value
    End If
   End If
  Next
 End With
 Exit Sub
ErrHandler:
 'エラーの発生の場合
 If Err.Number = 9 Then
  If Dir(FNAME) <> "" Then
   Workbooks.Open FNAME
   Resume 'エラーを発生した所まで戻る
  Else
   MsgBox "ファイルが見つからないか、パスを指定してください。", vbExclamation
   Exit Sub
  End If
 Else
  MsgBox Err.Number & " :" & Err.Description & " :" & Erl
 End If
End Sub

'//

 '配列の受け渡し
 c.Offset(, 1).Resize(, 3).Value = r.Offset(, 1).Resize(, 3).Value

入門・初級レベルでは、Copy メソッドのほうが良いでしょう。
r.Offset(, 1).Resize(, 3).Copy c.Offset(, 1)

こんばんは。

要するに、ソースファイル(データファイル)から情報を取り出す内容なのですね。
それをあえてFind メソッド指定なのかな?

>ActiveSheet.UsedRange.Select
だったら、以下は、Cells ではなくて、Selection でしょうね。

> Cells.Find(what:="A君", lookat:=xlPart)
なぜ、xlPart になっているのでしょうか?表記の乱れがあるということでしょうか?
変数の使い方とか、初歩的なところがまだ出来ていません。

>玄人の方からすれば何だこのマクロは
Findメソッド は、常連さんの某氏の専売特許の...続きを読む

Q【VBA】 for next 繰り返し処理の入れ子の処理速度について

こんにちわ
マクロを作成しております。
入れ子した繰り返し処理に躓いております、
もしよろしければ高速化のアドバイスをいただければと思います。


B2から下方向に値をいれております。
C1から横方向に同じ値をいれております。
B1-C1,B1-D1,B1-E1・・・最終まで
、というようにリーグ戦の総当たり結果表のような
結果を出力しようとしています。
値は数値で差分を整数で出すだけで、
重複した結果は不要ですので階段状に出力させています。

B列70行程で処理に40秒程かかってしまう状態です。
何か余計な処理や修正したほうがよさそうな箇所ははありますでしょうか?

excel2013
win8 メモリ4G

_______________
Sub test3()

Dim sh As Worksheet
Dim m As Long, i As Long, j As Long

Application.ScreenUpdating = False '非表示

Set sh = Worksheets("test")

m = sh.Cells(Rows.Count, "B").End(xlUp).Row

For i = 1 To m - 1
For j = i To m - 1

sh.Cells(j + 1, i + 2) = _
Application.WorksheetFunction.RoundDown( _
Abs(sh.Cells(1, 2).Offset(i, 0).Value - sh.Cells(1, 2).Offset(0, j).Value), 0)
      ’小数点切り捨てなど入れてます。
      ’単純にi+jにしても処理時間は変わりませんでした。
Next j
Next i


End Sub
_______________

以上です、よろしくお願いします。

こんにちわ
マクロを作成しております。
入れ子した繰り返し処理に躓いております、
もしよろしければ高速化のアドバイスをいただければと思います。


B2から下方向に値をいれております。
C1から横方向に同じ値をいれております。
B1-C1,B1-D1,B1-E1・・・最終まで
、というようにリーグ戦の総当たり結果表のような
結果を出力しようとしています。
値は数値で差分を整数で出すだけで、
重複した結果は不要ですので階段状に出力させています。

B列70行程で処理に40秒程かかってしまう状態です。
...続きを読む

Aベストアンサー

コードをそのままで、B列200行程度実行しても一瞬で終わります。

コードの問題では無いですね。
PC環境かエクセルの問題だと思います。

そもそも、そのエクセルに直接文字入力した場合、入力の度に待たされる事は有りませんか?

QEXCEL VBAとワークシート関数の混同は邪道なのでしょうか?

前任者が作成したEXCELファイルがあります。

VBAとユーザーフォームを作成して、ACCESSのようにまったくEXCELを知らない人でもルーティン作業ができるようになっています。
ただACCESSと違って、それを修正するのが大変です。
項目が1列又は1行増えるだけで、修正する箇所が何箇所も出てきます。

そこで少し作り変えようと思っているのですが、VBAと関数の混同は良くないのでしょうか?
① Application.WorksheetFunction.sum ではなく、
② シート作業列にSUM関数を入れる
②の場合では、他のモジュールやフォームからも参照できます。
又、変更するたびに①を実行させる必要もありません。

VBAとシート上の関数の混同は不都合はあるのでしょうか?
教えて下さい。

Aベストアンサー

「VBAとワークシート関数の混同は邪道」ではないと思います。

ただ次の点を注意する必要があるかと思います。

1.一番大きいのは「処理速度」です。
 ・セルに計算式を設定されていると、EXCELはセルに値を設定するごとに【再計算】が行われしまうことが、処理速度が大幅に低下
  することがあります。
  そのため、プログラムを実行する場合【自動計算】を一時的にストップさせています。
   Application.Calculation = xlManual
   ※処理完了後は「Application.Calculation = xlAutomatic」にします。
 ・ただ注意しないといけないのは「計算を手動」にした場合、関数で計算した値をプログラムで参照したい場合【再計算が必要】かも
  知れません。そのときは一時的に再計算をした方が間違いないかと思います。
   Range("B12").Calculate  … 特定セルだけ再計算
   Worksheets(1).Calculate  … 特定シートだけ再計算
   Application.Calculate    … 開いているすべてのブックを再計算

2.処理ロジック
  上記1.のように「再計算」を都度行う必要がある場合、漏れなく(ミス無く)対応が必要です。
  そのため、過去のプログラムを修正する場合はミスが無いようにしっかりとプログラム内容を理解することが求められます。
  ※しっかりテストすれば良いのかも知れませんが…

3.セルにプログラムで毎回計算式を設定するのなら…
 もしプログラムでセルに毎回計算式を設定するのなら「Application.WorksheetFunction」で計算した方が良いかも知れません。
 初めから計算式を設定するのなら「ユーザに式を触らせないようにシート保護」した方が良いかと思います。
 その場合、プログラムでセルに値を設定する場合、セルに書き込みできるように「シートの保護解除」等が必要になります。

◆VBAとワークシート関数の混同は邪道ではないですが、色々な問題点を意識して、プログラムを作成しないと思わぬ所で
 落とし穴があるかも知れませんので注意が必要ですね。

色々と大変だと思いますが頑張ってください。

「VBAとワークシート関数の混同は邪道」ではないと思います。

ただ次の点を注意する必要があるかと思います。

1.一番大きいのは「処理速度」です。
 ・セルに計算式を設定されていると、EXCELはセルに値を設定するごとに【再計算】が行われしまうことが、処理速度が大幅に低下
  することがあります。
  そのため、プログラムを実行する場合【自動計算】を一時的にストップさせています。
   Application.Calculation = xlManual
   ※処理完了後は「Application.Calculation = xlAutomatic」にしま...続きを読む

Qマクロの「SaveAs」でエラーが出るのを解消したいです(再)

下記のエラーが出ます、似たようなもので新規ファイルで保存できたのですが
今回は出来ない状態になってしまいました。
ちょこちょこマクロ使うのですが、初心者で解決できません。
マクロ先生のご指導をお願いします。
※コピーされたシートが新ファイルで開かれた状態でエラー表示となります。


「実行時エラー '1004':

'SaveAs' メソッドは失敗しました: '_Worksheet' オブジェクト」


'指定額の抽出
Private Const MESSAGE_FINISH = "予算出力処理が完了しました"

Sub 予算データテキスト出力()
Dim ws1
Set ws1 = Worksheets("チェック一覧")
Dim m As Long
m = 3
Dim ws2
Set ws2 = Worksheets("予算データ")

Dim sm As String

Dim ws3

Dim sn

'チェック一覧シートのNo.が無くなるまで処理する
Do Until ws1.Cells(m, 1) = ""

Application.ScreenUpdating = False


If ws1.Cells(m, 4) = "" Then
'ナンバーがある場合は部門等をチェック一覧(ws1)→フォーム(ws2)に転記する
Else
ws2.Cells(2, 2) = ws1.Cells(m, 4)

'各部署のシート名をsmにセットする
sm = ws1.Cells(m, 2)
Set ws3 = Worksheets(sm)

'予算フォーム(ws2)の行変数「s」と各部署シート(ws3)の行変数「n」
Dim s
s = 4
Dim n
n = 9
Dim cnt
cnt = 1

Do Until n = 44
If ws3.Cells(n, 23) = 0 Then

'各数値等を各部署のシート(ws3)→フォーム(ws2)に転記する
Else

ws2.Cells(s, 1) = cnt
ws2.Cells(s, 3) = 6100
ws2.Cells(s, 4) = 0
ws2.Cells(s, 5) = ws3.Cells(3, 4)
ws2.Cells(s, 6) = ws3.Cells(5, 8)

ws2.Cells(s, 7) = ws3.Cells(n, 4)
ws2.Cells(s, 8) = ws3.Cells(n, 24)
ws2.Cells(s, 9) = ws3.Cells(n, 25)
ws2.Cells(s, 10) = ws3.Cells(n, 26)
ws2.Cells(s, 11) = ws3.Cells(n, 27)
ws2.Cells(s, 12) = ws3.Cells(n, 28)
ws2.Cells(s, 13) = ws3.Cells(n, 29)
ws2.Cells(s, 14) = ws3.Cells(n, 31)
ws2.Cells(s, 15) = ws3.Cells(n, 32)
ws2.Cells(s, 16) = ws3.Cells(n, 33)
ws2.Cells(s, 17) = ws3.Cells(n, 34)
ws2.Cells(s, 18) = ws3.Cells(n, 35)
ws2.Cells(s, 19) = ws3.Cells(n, 36)
s = s + 1
cnt = cnt + 1

End If

n = n + 1

Loop
'予算データに転記されたので出力する

ws2.Copy

' ↓↓↓↓↓この下の「SaveAs」がエラーになります。↓↓↓↓↓

ActiveWorkbook.SaveAs Filename:="D:\Library\Desktop\新しいフォルダー\" & ws2.Cells(s, 5).Value & ".txt", FileFormat:=xlText

ActiveWindow.Close

ActiveWorkbook.Close savechanges:=False


'フォームに転記した情報をクリア
ws2.Select
Range(Cells(4, 1), Cells(44, 19)).Select
Selection.ClearContents


End If

m = m + 1


Loop

ws1.Select

MsgBox MESSAGE_FINISH

End Sub

下記のエラーが出ます、似たようなもので新規ファイルで保存できたのですが
今回は出来ない状態になってしまいました。
ちょこちょこマクロ使うのですが、初心者で解決できません。
マクロ先生のご指導をお願いします。
※コピーされたシートが新ファイルで開かれた状態でエラー表示となります。


「実行時エラー '1004':

'SaveAs' メソッドは失敗しました: '_Worksheet' オブジェクト」


'指定額の抽出
Private Const MESSAGE_FINISH = "予算出力処理が完了しました"

Sub 予算データテキスト...続きを読む

Aベストアンサー

No1の方が指摘されているように、
ActiveWorkbook.SaveAs Filename:="D:\Library\Desktop\新しいフォルダー\" & ws2.Cells(s, 5).Value & ".txt", FileFormat:=xlText
のときの、 ws2.Cells(s, 5).Valueの値が不正な可能性があります。

この行の直前で、
msgbox("<" & ws2.Cells(s, 5).Value & ">")
を行い、ws2.Cells(s, 5).Valueの内容を確認しては、いかがでしょうか。

QVBA コンパイルエラーの解消法

皆様、いつもお世話になっております。
初心者なりに考えてVBAを組んでみたのですが、「Sub または Fanction が定義されていません」とエラー表示が出てきます。
自分なりにコードに間違いがないか検索ながらやってみたのですが、うまくいきません。

どなたか、知恵をお貸しいただけないでしょうか。



テーブルの入っているSheet1から、シート”施工体制台帳~”の該当するセルにデータのコピーを行うためのVBAです。
業者の数だけループするように組んだつもりなのですが、エラー表示のため実行ができません。
ご指摘、よろしくお願いいたします。

Sub kopipe1() '施工体制台帳
Dim sh As Worksheet
Dim sh1 As Worksheet
Dim sb As Long
Dim m As Long
Dim p As Long
Dim c As Long
Dim i As Long
Dim end1 As Long

Set sh = Worksheet("sheet1")
Set sh1 = Worksheet("施工体制台帳 (下請け) ")


end1 = sh.Range(".Cells(Rows.Count, 2)").End(xlUp)
sb = 1
p = 1

For i = 2 To end1 Step 1
sb = sb + 1
c = cell(p, 9)

sh.cell(sb, 2).Copy Destination:=.sh1.Range(c).Offset(2, 1) '会社名
sh.cell(sb, 3).Copy Destination:=.sh1.Range(c).Offset(2, 27) '代表者名
sh.cell(sb, 4).Copy Destination:=.sh1.Range(c).Offset(4, 1) '郵便番号
sh.cell(sb, 5).Copy Destination:=.sh1.Range(c).Offset(5, 1) '住所
sh.cell(sb, 6).Copy Destination:=.sh1.Range(c).Offset(6, 24) '電話番号
sh.cell(sb, 7).Copy Destination:=.sh1.Range(c).Offset(13) '業種1
sh.cell(sb, 8).Copy Destination:=.sh1.Range(c).Offset(14, 12) '許可者1
sh.cell(sb, 9).Copy Destination:=.sh1.Range(c).Offset(14, 15) '区分1
sh.cell(sb, 10).Copy Destination:=.sh1.Range(c).Offset(14, 17) '許可1-1
sh.cell(sb, 11).Copy Destination:=.sh1.Range(c).Offset(14, 20) '許可1-2
sh.cell(sb, 12).Copy Destination:=.sh1.Range(c).Offset(14, 27) '許可年月日
sh.cell(sb, 13).Copy Destination:=.sh1.Range(c).Offset(16) '業種2
sh.cell(sb, 14).Copy Destination:=.sh1.Range(c).Offset(17, 12) '許可者2
sh.cell(sb, 15).Copy Destination:=.sh1.Range(c).Offset(17, 15) '区分2
sh.cell(sb, 16).Copy Destination:=.sh1.Range(c).Offset(17, 17) '許可2-1
sh.cell(sb, 17).Copy Destination:=.sh1.Range(c).Offset(17, 20) '許可2-2
sh.cell(sb, 18).Copy Destination:=.sh1.Range(c).Offset(17, 27) '許可年月日2
sh.cell(sb, 19).Copy Destination:=.sh1.Range(c).Offset(21, 28) '健康保険
sh.cell(sb, 20).Copy Destination:=.sh1.Range(c).Offset(22, 28) '厚生年金保険
sh.cell(sb, 21).Copy Destination:=.sh1.Range(c).Offset(23, 28) '雇用保険
sh.cell(sb, 22).Copy Destination:=.sh1.Range(c).Offset(25, 3) '現場代理人指名
sh.cell(sb, 23).Copy Destination:=.sh1.Range(c).Offset(29, 7) '主任技術者氏名
sh.cell(sb, 24).Copy Destination:=.sh1.Range(c).Offset(31, 3) '資格内容
sh.cell(sb, 25).Copy Destination:=.sh1.Range(c).Offset(33, 3) '安全衛生責任者
sh.cell(sb, 26).Copy Destination:=.sh1.Range(c).Offset(25, 26) '安全衛生推進者
sh.cell(sb, 27).Copy Destination:=.sh1.Range(c).Offset(27, 26) '雇用管理責任者
sh.cell(sb, 28).Copy Destination:=.sh1.Range(c).Offset(29, 26) '専門技術者名
sh.cell(sb, 29).Copy Destination:=.sh1.Range(c).Offset(31, 26) '技術資格内容

p = p + 62
Exit For
Next i
End Sub

皆様、いつもお世話になっております。
初心者なりに考えてVBAを組んでみたのですが、「Sub または Fanction が定義されていません」とエラー表示が出てきます。
自分なりにコードに間違いがないか検索ながらやってみたのですが、うまくいきません。

どなたか、知恵をお貸しいただけないでしょうか。



テーブルの入っているSheet1から、シート”施工体制台帳~”の該当するセルにデータのコピーを行うためのVBAです。
業者の数だけループするように組んだつもりなのですが、エラー表示...続きを読む

Aベストアンサー

今のところ、変数に代入する以外のコードはほとんど間違っているわけですから、どれがどうと言えないと思います。
他の方との重複を含みます。
・Worksheet(---) ->Worksheets(----)
・sh.Range(".Cells(Rows.Count, 2)").End(xlUp)
  ↓
sh.Cells(Rows.Count, 2).End(xlUp).Row
・c = cell(p, 9)
  ↓
 c = Cells(p, 9) ただし、最後に、p = p + 62の後、Exit For では、1回キリでおしまいになってしまいます。

おそらくは、Dim c As String --Cells(p, 9).Address(0,0)
のはずです。
 
・sh.cell(sb, 2).Copy Destination:=.sh1.Range(c).Offset(2, 1) '会社名
とりあえず、Cells と sh1 のコンマは取るけれども、
sh1.Range(c).Offset(2, 1) これでは可読性を落とすばかりで分かりません。

これ自体を直すよりは、最初から作り直したほうが早そうです。
たぶん、一覧で横に並んでいるものを、別のシートの各場所に振り替えていくわけで、それが、ページごとになっているというわけでしょう。

まず、 sh1.cells(sb, 2).Copy ですが、
その列の2 を変数にすべきですね。

受ける側が、Offset で書かれてしまうと、手がつけられなくなってしまいます。

sh1.Range("J3,AJ3,J5,J6,AG7,I14,U15,X15,Z15,AC15,AJ15,I17," & _
 "U18,X18,Z18,AC18,AJ18,AK22,AK23,AK24,L26,P30,L32,L34," & _
 "AI26,AI28,AI30,AI32")

このようにまとめてしまい、以下のように纏めたものから呼び出すようにします。
しかし、実際にやってみると不具合が生じるので、それを配列で渡すようにします。

注:以下は、私の想像で書かれたものであって、実際に合っているのかは分かりません。
このようなスタイルにしてみたらという、あくでもこちらの提案です。

'//
Sub Test1()
 Dim Rng As Range
 Dim i As Long, j As Long, sb As Long
 Dim c As Variant
 Dim sh As Worksheet, sh1 As Worksheet
 Set sh = Worksheets("sheet1")
 Set sh1 = Worksheets("施工体制台帳 (下請け)")

 
 Set Rng = sh1.Range("J3,AJ3,J5,J6,AG7,I14,U15,X15,Z15,AC15,AJ15,I17," & _
 "U18,X18,Z18,AC18,AJ18,AK22,AK23,AK24,L26,P30,L32,L34," & _
 "AI26,AI28,AI30,AI32")
 
 end1 = sh.Cells(Rows.Count, 2).End(xlUp).row
 
 i = 2
 sb = 2
 For j = 1 To end1
 a = (j - 1) * 62 + 1
  For Each c In Rng.Offset((j - 1) * 62 + 1)
   c.Value = sh.Cells(sb, i).Value
   DoEvents
   i = i + 1
  Next
  i = 2
  sb = sb + 1
 Next
End Sub

今のところ、変数に代入する以外のコードはほとんど間違っているわけですから、どれがどうと言えないと思います。
他の方との重複を含みます。
・Worksheet(---) ->Worksheets(----)
・sh.Range(".Cells(Rows.Count, 2)").End(xlUp)
  ↓
sh.Cells(Rows.Count, 2).End(xlUp).Row
・c = cell(p, 9)
  ↓
 c = Cells(p, 9) ただし、最後に、p = p + 62の後、Exit For では、1回キリでおしまいになってしまいます。

おそらくは、Dim c As String --Cells(p, 9).Address(0,0)
のはずです。
 
・sh.cell(sb, 2).C...続きを読む

QエクセルVBAで今まで使えていたものが使えなくなった原因を教えてください。

下記コードは「特定のシート(あいうえお、とします。)をコピーして、新しいブックを作り一定の範囲(A1:I38、とします)を値貼り付けし、一部(J:N、とします。)非表示にして任意の名前(L17に名前が出るようにしてありそれを引用してます)を付けて指定の場所(フェイクの為、適当。)へ保存する」という内容のものです。

Sub 保存()
Sheets("あいうえお").Copy
Range("A1:I38").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("J:N").Select
Selection.EntireColumn.Hidden = True
Dim fname As string

fname = Application.GetSaveAsFilename(InitialFileName:="C\:~~~" & Range("L17").Value)

If fname <> "false" Then
ActiveWorkbook.SaveAs Filename:=fname
End If

End Sub

ある時から、「型が一致しません」といったエラーが出るようになってしまいました。
何かをしたという記憶もありませんし、原因が思い当りません。。
自分で調べてみたのですが、どうにもわからなかったのでどうにかお力添えください…

ここに書いたもの以外で必要な情報があれば、できる限り出しますので教えてください。
宜しくお願い致します。

下記コードは「特定のシート(あいうえお、とします。)をコピーして、新しいブックを作り一定の範囲(A1:I38、とします)を値貼り付けし、一部(J:N、とします。)非表示にして任意の名前(L17に名前が出るようにしてありそれを引用してます)を付けて指定の場所(フェイクの為、適当。)へ保存する」という内容のものです。

Sub 保存()
Sheets("あいうえお").Copy
Range("A1:I38").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
...続きを読む

Aベストアンサー

マクロを本格的に書く時は、Select をなくせと言います。
今の段階では、はっきりどこが間違いかというと、以下の部分だけです。
File名が、String 型なら、
>If fname <> "false" Then
この部分は間違っています。"False" です。
文字列をそのまま比較すると、binary 比較になってしまうからです。
StrComp 関数などもありますが、ややこしいので、戻り値のままに扱うか、
もしくは、以下のように Vartype 関数を利用します。

それ以上は、任意の部分に関しては、.Range("L17").Value が確実に代入できているか調べるぐらいしかありません。

'これで試してみていただけますか?
'パスの所は適当に変えてください。

Sub 保存2()
Dim fName As Variant
Dim buf As String
Dim wb As Workbook
Dim myPath As String
 '必要に応じて書き換えてください。
 myPath = ThisWorkbook.Path & "\" '末尾には必ず¥を入れてください。
 Worksheets("あいうえお").Copy
 
 Set wb = ActiveWorkbook
 With ActiveSheet
 .Range("A1:I38").Value = .Range("A1:I38").Value '値コピー
 .Columns("J:N").EntireColumn.Hidden = True
  buf = .Range("L17").Value
  If Trim(buf) = "" Then
   MsgBox "ファイル名がありません。", vbCritical
   Exit Sub
  End If
    fName = Application.GetSaveAsFilename( _
    InitialFileName:=myPath & buf, _
    FileFilter:="Excel Files(xlsx(*.xlsx),xlsm(*.xlsm)", _
    Title:="ファイル保存")
  If VarType(fName) = vbBoolean Then
  wb.Close False
  Exit Sub
  End If
 End With
  wb.SaveAs Filename:=fName, FileFormat:=xlOpenXMLWorkbook
  wb.Close False
End Sub

マクロを本格的に書く時は、Select をなくせと言います。
今の段階では、はっきりどこが間違いかというと、以下の部分だけです。
File名が、String 型なら、
>If fname <> "false" Then
この部分は間違っています。"False" です。
文字列をそのまま比較すると、binary 比較になってしまうからです。
StrComp 関数などもありますが、ややこしいので、戻り値のままに扱うか、
もしくは、以下のように Vartype 関数を利用します。

それ以上は、任意の部分に関しては、.Range("L17").Value が確実に代入できているか...続きを読む

Q【VBA】IF文 複数(ネスト)の時の処理について

こんにちは。
if文についておしえてください。
以下のようなマクロがあるとします。

変数 tensuuに-1をいれて実行すると①→②のように動作し「入力エラー」と表示されます。
tensuuに120を入れて実行すると①´→②´の順に動作し「入力エラー1」と表示されます。

どして、-1のときは入力エラー1にはいかず入力エラーにいくのでしょうか?
120のときは入力エラーにはいかず入力エラー1にいくのでしょうか?

動きがよくわかりません。
IF文とELSEはどういう紐づけがされているのでしょうか?

よろしくおねがいいたします。
   
Sub t()
tensuu = -1
If tensuu >= 0 Then '①
If tensuu <= 100 Then '①´
If tensuu >= 80 Then
MsgBox "合格"
Else
MsgBox "不合格"
End If
Else
MsgBox "入力エラー1" '②´
End If
Else
MsgBox "入力エラー" '②
End If
End Sub

こんにちは。
if文についておしえてください。
以下のようなマクロがあるとします。

変数 tensuuに-1をいれて実行すると①→②のように動作し「入力エラー」と表示されます。
tensuuに120を入れて実行すると①´→②´の順に動作し「入力エラー1」と表示されます。

どして、-1のときは入力エラー1にはいかず入力エラーにいくのでしょうか?
120のときは入力エラーにはいかず入力エラー1にいくのでしょうか?

動きがよくわかりません。
IF文とELSEはどういう紐づけがされているのでしょうか?

よろし...続きを読む

Aベストアンサー

If 〜 Then 〜 Else 〜 End If
で1セットです。

ネスト(入れ子)になったIF文というのは、 Then 〜 とか Else 〜 の〜の部分にIf文がくるものです。
ですから、外のIfを越えてしまうことはありません。
よって、一番内側から見ていけば、構造がはっきりします。


一番内側から見ます。

If tensuu >= 80 Then
MsgBox "合格"
Else
MsgBox "不合格"
End If

が1セットです。
これを 「文1」とすると元のプログラムは

If tensuu >= 0 Then '①
If tensuu <= 100 Then '①´
「文1」
Else
MsgBox "入力エラー1" '②´
End If
Else
MsgBox "入力エラー" '②
End If

となります。この状態で「一番内側」を見ると

If tensuu <= 100 Then '①´
「文1」
Else
MsgBox "入力エラー1" '②´
End If
です。これを「文2」とすると

If tensuu >= 0 Then '①
「文2」
Else
MsgBox "入力エラー" '②
End If


余談ですが
この例の場合、外側2つは、判定内容と処理とが離れてしまい、見辛いのは確かです。
if 条件 Then A Else B は if not条件 Then B Else A と同じ、ということから、Thenでの処理とElseでの処理を入れかえれば、
条件の直ぐ下の処理が来るので、見易さが格段によくなります。

If tensuu < 0 Then '① ' tensuu<0 は not (tensuu>=0)と同じ
MsgBox "入力エラー" '②
ElseIf tensuu > 100 Then '①´
MsgBox "入力エラー1" '②´
ElseIf tensuu >= 80 Then
MsgBox "合格"
Else
MsgBox "不合格"
End If ' ElseIfで継いでいるので、ネストにはなっていない

If 〜 Then 〜 Else 〜 End If
で1セットです。

ネスト(入れ子)になったIF文というのは、 Then 〜 とか Else 〜 の〜の部分にIf文がくるものです。
ですから、外のIfを越えてしまうことはありません。
よって、一番内側から見ていけば、構造がはっきりします。


一番内側から見ます。

If tensuu >= 80 Then
MsgBox "合格"
Else
MsgBox "不合格"
End If

が1セットです。
これを 「文1」とすると元のプログラムは

If tensuu >= 0 Then '①
If tensuu <= 100 Then '①´
「文1」
Else
MsgBox "入力エラー1" '②´
...続きを読む

Q重複するパターンの算出について。

エクセルについて教えていただきたく、質問をさせていただいております。
長文でわかりずらいのですが、お力添えいただければ幸いです。

画像のように、シート1のA2~I9データの、全ての重複組み合わせのパターンを、シート2に出力する方法を、VBAを使って実現することは可能でしょうか。
左の画像の場合、(2.3.4.5.6.7.8.9)(1.3.4.5.6.7.8.9)(1.2.4.5.6.7.8.9)(1.2.3.5.6.7.8.9)(1.2.3.4.6.7.8.9)(1.2.3.4.5.7.8.9)(1.2.3.4.5.6.8.9)(1.2.3.4.5.6.7.9)(1.2.3.4.5.6.7.8)の9つのデータの重複組み合わせのすべてのパターンを出力した場合です。

実際には、右の図のように数値が虫食いのように、消えて変動するので、その時に、VBAを使ったマクロボタンにてデータを算出できるようにできればと考えております。

実際には、出力結果がエクセルの最大行数内で収まる場合のみに使用する目的です。

エクセルに詳しい方がいらっしゃいましたら、お力添えいただけると助かります。
宜しくお願い致します。

エクセルについて教えていただきたく、質問をさせていただいております。
長文でわかりずらいのですが、お力添えいただければ幸いです。

画像のように、シート1のA2~I9データの、全ての重複組み合わせのパターンを、シート2に出力する方法を、VBAを使って実現することは可能でしょうか。
左の画像の場合、(2.3.4.5.6.7.8.9)(1.3.4.5.6.7.8.9)(1.2.4.5.6.7.8.9)(1.2.3.5.6.7.8.9)(1.2.3.4.6.7.8.9)(1.2.3.4.5.7.8.9)(1.2.3.4.5.6.8.9)(1.2.3.4.5.6.7.9)(1.2.3.4.5.6.7.8)の9つのデータの重複組み合...続きを読む

Aベストアンサー

以下のマクロを標準モジュールに登録してください。
文字数オーバーなので下記URLに記述しました。
http://climbi.com/b/10197/0

使用時の注意事項です。
実際のシート名ですが
シート1はSheet1
シート2はSheet2
であることが前提です。
Sheet2の2行目から出力します。(1行目はそのままです。変更されません)

Const MaxLimit As Long = 10000
ですが、組み合わせの件数が、この値を超えた場合、処理をしないようにしています。
現在は10000なので、最大行数の1,048,576 行まで出力するなら、
Const MaxLimit As Long = 1048575 としてください。(2行目から書くので、出力できる件数は1件少なくなります。)
但し、1048575 を設定すると、excelの限界まで書きますので、その結果、どうなるかは私は判りません。(自己責任でお願いします)
(最低でも該当ブックのバックアップをとってから実行なさってください)

MaxLimit 以内の場合でも、実行前に「実行するかどうか」の確認メッセージがでますので、キャンセルをクリックすれば中止します。

以下のマクロを標準モジュールに登録してください。
文字数オーバーなので下記URLに記述しました。
http://climbi.com/b/10197/0

使用時の注意事項です。
実際のシート名ですが
シート1はSheet1
シート2はSheet2
であることが前提です。
Sheet2の2行目から出力します。(1行目はそのままです。変更されません)

Const MaxLimit As Long = 10000
ですが、組み合わせの件数が、この値を超えた場合、処理をしないようにしています。
現在は10000なので、最大行数の1,048,576 行まで出力するなら、
Const MaxLimit...続きを読む


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング