Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

155 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【79363】Re:複数ブック・複数シートから1行コピー...

マナ - 17/9/5(火) 20:18 -


	引用なし

	パスワード

▼sakura さん：

すべてのシートで処理をさせる構文は、

For Each ws In wb.Worksheets
　　ここに処理内容
Next

-------
条件を満たした場合のみ処理する構文は、

If 条件 Then
　　ここに処理内容
End If

-------
で、こうすると
Sheetで始まるシートのみ処理できます。

For Each ws In wb.Worksheets
　　If ws.Name Like "Sheet*" Then
　　　　LastRow = tb.Sheets(TotalSheet).Rows(Rows.Count).End(xlUp).Row + 1
　
　　　　' 行ごとのコピーを行うとなぜかずれるので値のみコピーしてみる。
　　　　ws.Rows(TargetRow).Copy
　　　　tb.Sheets(TotalSheet).Rows(LastRow).PasteSpecial (xlPasteValues)
　　End If
Next

-------
あとは、

>TargetSheet = "Sheet1"
これを

TargetSheet = "Sheet*"
に変更すれば

>If ws.Name Like "Sheet*" Then
は、

If ws.Name Like TargetSheet　Then
にするとよいです。

・ツリー全体表示


	【79362】Re:複数ブック・複数シートから1行コピー...

sakura - 17/9/5(火) 12:11 -


	引用なし

	パスワード

おそらく、かなりおなしなことをしてしまっているだろうと思い、自分なりに…の部分を割愛させていただきましたが…
恥をしのんで、、
下記のように、もとのコードの59行目の Set wh = Workbooks… の部分を、教えていただいたコードに置き換えました。
また、25行目+指定している TargetSheet もこのままではダメかな⁈と思い、コメントにしています。
お手数をおかけして申し訳ありませんが、もしよろしければ、どこをどう変更すれば良いか、までお教えいただけると大変助かります。
勉強不足で大変恐縮です。。
よろしくお願いいたしますm(__)m

Sub アンケート集計実行()
　　Dim wbn As Workbook
　　Dim wb As Workbook
　　Dim tb As Workbook
　　Dim TotalDir As String
　　Dim TotalSheet As String
　　Dim TargetSheet As String
　　Dim TargetFile As String
　　Dim TargetRow As String
　　Dim StartRow As String
　　Dim LastRow As String
　　Dim modeFlag As Boolean
　
'====================================================
'　　　　　　　　　　　値の設定
'====================================================
　
　　' 集計対象フォルダの指定
　　TotalDir = "C:\Users\NS26517\OneDrive - Teijin-Frontier\201708法務審査_下請調査関係\アンケート集計"

　　' 集計対象シートの指定
　　TargetSheet = "Sheet1"
　　　
　　' 集計用シートの指定
　　TotalSheet = "集計"
　　　
　　' 集計対象行の指定
　　TargetRow = "2"
　
　　' 集計結果記載開始行を指定
　　StartRow = "2"
　
　　' 追記するかしないかフラグ(True : 追記する、False: 追記しない)
　　modeFlag = False

'====================================================
'　　　　　　　　　　　実処理
'====================================================
　　Set tb = ThisWorkbook
　
　　If modeFlag = False Then
　　　　　　LastRow = tb.Sheets(TotalSheet).Rows(Rows.Count).End(xlUp).Row + 1
　　　　　　tb.Sheets(TotalSheet).Range(StartRow & ":" & LastRow).Delete
　　End If
　　　
　　TargetFile = Dir(TotalDir & "\*.xlsx", vbNormal)
　　Do While TargetFile <> ""
　　　　If TotalDir & "\" & TargetFile <> TotalFile Then
　　　　　　For Each wbn In Workbooks
　　　　　　　　If wbn.Name = TargetFile Then
　　　　　　　　　　MsgBox TargetFile & " は、既に開かれています。" & vbCrLf & "集計処理を中止します。"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　Next wbn
　　　　　　Set wb = Workbooks.Open(TotalDir & "\" & TargetFile)
　　　　　　For Each ws In wb.Worksheets
　　　　　　　　If ws.Name Like "Sheet*" Then
　　　　　　LastRow = tb.Sheets(TotalSheet).Rows(Rows.Count).End(xlUp).Row + 1
　
　　　　　　' 行ごとのコピーを行うとなぜかずれるので値のみコピーしてみる。
　　　　　　wb.Sheets(TargetSheet).Rows(TargetRow).Copy
　　　　　　tb.Sheets(TotalSheet).Rows(LastRow).PasteSpecial (xlPasteValues)
　　　　　
　　　　　　' クリップボード警告対策
　　　　　　tb.Sheets(TotalSheet).Range("A1").Copy
　　　　　
　　　　　　' 集計対象ファイルを閉じる
　　　　　　wb.Close False

　　　　End If
　　　
　　　　TargetFile = Dir()
　　Loop
　
　　' クリップボード警告対策
　　tb.Sheets(TotalSheet).Range("A1").Copy
　
　　' 集計ファイルを保存
　　tb.Save

　　' 集計後のファイルを閉じる
　　' tb.Close True
　
　　' 完了を通知
　　MsgBox "集計を完了しました。"
End Sub

・ツリー全体表示


	【79361】行と列の抽出

boss - 17/9/5(火) 9:19 -


	引用なし

	パスワード

Sheet1のA1からJ10に値が入っており、Sheet2に行と列それぞれ2行おきに
A1からE5で値を取得したいのですがうまくいきません。

=INDEX(Sheet1!$A$1:$J$10,ROW($A1)*2,COLUMN(A$1)*2)

すみませんがお力添えいただきたく。

・ツリー全体表示


	【79360】Re:複数ブック・複数シートから1行コピー...

マナ - 17/9/4(月) 19:36 -


	引用なし

	パスワード

▼sakura さん：

>自分なりにやると、コンパイルエラーになってしまいました。

どのようにしたか、教えてください。

・ツリー全体表示


	【79359】Re:複数ブック・複数シートから1行コピー...

sakura - 17/9/4(月) 9:57 -


	引用なし

	パスワード

マナさん
ありがとうございます‼
無知でお恥ずかしい限りですが、どこにどのように組み込めば良いかがわかりません…
自分なりにやると、コンパイルエラーになってしまいました。
引き続きアドバイスをお願いできますでしょうか⁈
よろしくお願いいたしますm(__)m

・ツリー全体表示


	【79358】Re:Timer関数を使って

γ - 17/9/3(日) 23:27 -


	引用なし

	パスワード

適当に忖度するとこういうことですか？

Option Explicit

Dim startTime

Sub ボタン1_Click()　 'タイマーをスタート
　　startTime = Timer
End Sub

Sub ボタン2_Click()　 'タイマーを終了させる。経過時間(秒）を表示。
　　MsgBox Timer - startTime
End Sub

・ツリー全体表示


	【79357】Re:Timer関数を使って

γ - 17/9/3(日) 23:16 -


	引用なし

	パスワード

そのタイマーの機能を説明して下さい。
また、タイマーを終了するとは具体的にどのようなことを考えているのですか？
Timer関数自体は、午前0時からの秒数を返すだけですが。

・ツリー全体表示


	【79356】Timer関数を使って

もろたつ - 17/9/3(日) 21:26 -


	引用なし

	パスワード

コマンドボタンを押すとタイマーが起動し、別のコマンドボタンを押すとタイマーが終了をするようにするにはどうすれば良いでしょうか？

・ツリー全体表示


	【79355】Re:複数ブック・複数シートから1行コピー...

マナ - 17/9/3(日) 14:07 -


	引用なし

	パスワード

▼sakura さん：

こんな感じで、開いたブックについて
For Each～Nextでループし、シート名を確認しながら
転記するようにしてはどうですか。

Set wb = Workbooks.Open(TotalDir & "\" & TargetFile)
For Each ws In wb.Worksheets
　　If ws.Name Like "Sheet*" Then

・ツリー全体表示


	【79354】複数ブック・複数シートから1行コピーし...

sakura - 17/9/3(日) 0:05 -


	引用なし

	パスワード

教えてください。
環境は、Windows10 Enterprise　（ビルド1607）　Excel2016　です。
1つのフォルダに100を超える数のエクセルブックがあり、それぞれのブックの中には複数のワークシートがあります。
全ブックから、シート名に　「Sheet」　と付くワークシート（Sheet1・Sheet10など）の2行目だけを抜き出して、別の集計用ブックにまとめるマクロを作成する必要があります。
前任者が作成したvbaで、複数ブックの　「Sheet1」　の2行目だけを抜き出すマクロはあるのですが、これをアレンジしてなんとかならないでしょうか？

Sub アンケート集計実行()
　　Dim wbn As Workbook
　　Dim wb As Workbook
　　Dim tb As Workbook
　　Dim TotalDir As String
　　Dim TotalSheet As String
　　Dim TargetSheet As String
　　Dim TargetFile As String
　　Dim TargetRow As String
　　Dim StartRow As String
　　Dim LastRow As String
　　Dim modeFlag As Boolean
　
'====================================================
'　　　　　　　　　　　値の設定
'====================================================
　
　　' 集計対象フォルダの指定
　　TotalDir = "C:\アンケート集計"

　　' 集計対象シートの指定
　　TargetSheet = "Sheet1"
　　　
　　' 集計用シートの指定
　　TotalSheet = "集計"
　　　
　　' 集計対象行の指定
　　TargetRow = "2"
　
　　' 集計結果記載開始行を指定
　　StartRow = "2"
　
　　' 追記するかしないかフラグ(True : 追記する、False: 追記しない)
　　modeFlag = False

'====================================================
'　　　　　　　　　　　実処理
'====================================================
　　Set tb = ThisWorkbook
　
　　If modeFlag = False Then
　　　　　　LastRow = tb.Sheets(TotalSheet).Rows(Rows.Count).End(xlUp).Row + 1
　　　　　　tb.Sheets(TotalSheet).Range(StartRow & ":" & LastRow).Delete
　　End If
　　　
　　TargetFile = Dir(TotalDir & "\*.xlsx", vbNormal)
　　Do While TargetFile <> ""
　　　　If TotalDir & "\" & TargetFile <> TotalFile Then
　　　　　　For Each wbn In Workbooks
　　　　　　　　If wbn.Name = TargetFile Then
　　　　　　　　　　MsgBox TargetFile & " は、既に開かれています。" & vbCrLf & "集計処理を中止します。"
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　Next wbn
　　　　　　Set wb = Workbooks.Open(TotalDir & "\" & TargetFile)
　　　　　　LastRow = tb.Sheets(TotalSheet).Rows(Rows.Count).End(xlUp).Row + 1
　
　　　　　　' 行ごとのコピーを行うとなぜかずれるので値のみコピーしてみる。
　　　　　　wb.Sheets(TargetSheet).Rows(TargetRow).Copy
　　　　　　tb.Sheets(TotalSheet).Rows(LastRow).PasteSpecial (xlPasteValues)
　　　　　
　　　　　　' クリップボード警告対策
　　　　　　tb.Sheets(TotalSheet).Range("A1").Copy
　　　　　
　　　　　　' 集計対象ファイルを閉じる
　　　　　　wb.Close False

　　　　End If
　　　
　　　　TargetFile = Dir()
　　Loop
　
　　' クリップボード警告対策
　　tb.Sheets(TotalSheet).Range("A1").Copy
　
　　' 集計ファイルを保存
　　tb.Save

　　' 集計後のファイルを閉じる
　　' tb.Close True
　
　　' 完了を通知
　　MsgBox "集計を完了しました。"
End Sub

あるいは、別の方法でも結構ですので、お知恵をお貸しいただけますと幸いです。
どうぞよろしくお願いいたします。

・ツリー全体表示


	【79353】Re:抽出先で更新されたデータを反映させ...

ぴぐもん - 17/8/12(土) 23:25 -


	引用なし

	パスワード

▼γ さん：
ありがとうございます。フィルタはVBAを組む前はそうしていたんですが、仕事環境が変わり、マクロを組み検索時は数字のみ（不変データ）入力しあとはクリックのみで修正を行い反映もクリックひとつで終わらせ、検索情報を入力する状態に持って行くのが理想でした。ユニークなＩＤ・・それでためしてみます。

・ツリー全体表示


	【79352】Re:抽出先で更新されたデータを反映させ...

γ - 17/8/12(土) 23:18 -


	引用なし

	パスワード

了解です。
単純に修正後の領域を、元のデータにうわがきしても、
元データが抽出した状態になっていてもうまくいきません。
非表示セルにも書き込まれるのは仕様です。

そもそも、フィルタを掛けた状態の元のシートを直接修正するのでは
まずいのですか？

それが駄目なら、ユニークなIDを付した列を追加して、
それをたよりに、元のデータを更新していくかですね。

・ツリー全体表示


	【79351】Re:抽出先で更新されたデータを反映させ...

ぴぐもん - 17/8/12(土) 22:53 -


	引用なし

	パスワード

すみませんでした。
反映というのは、
抽出したデータを表示させたシート上で修正する。
反映ボタンを押すと、修正されたデータは”リスト”側の元データへ戻り、検索前のデータを上書きするという動作をしたいと考えています。
元データ”リスト”シートでは、Ａ列は不変でＢ列～Ｇ列が修正する可能性があるデータとなります。

・ツリー全体表示


	【79350】Re:抽出先で更新されたデータを反映させ...

γ - 17/8/12(土) 20:50 -


	引用なし

	パスワード

> これで抽出はうまくいくのですが、反映する際、
反映する
ということを正確に表現して下さい。
抽象的すぎてわかりません。

・ツリー全体表示


	【79349】抽出先で更新されたデータを反映させるに...

ぴぐもん - 17/8/12(土) 19:41 -


	引用なし

	パスワード

　”リスト”シートにはＡ１～Ｇ１が項目、Ａ２～Ｇ２からデータがあります。
”検索”シートに条件を入力し検索ボタンを入力すれば一致するデータが表示されます。Ａ１～Ｇ１項目、Ａ２～Ｇ２が検索条件、Ａ４～Ｇ４が結果表示用項目
Ａ５～Ｇ５が抽出結果表示欄（複数あれば続けてＡ６～〇５で表示）
抽出結果を修正し、反映ボタンを押せば”リスト”シートが更新される。

このようなマクロボタンを作りたいと考えています。

Sub 正方形長方形2_Click()
Sheets("検索").Rows("4:65536").ClearContents
　　Sheets("リスト").Select
　　Range("A2").Select
　　ActiveCell.CurrentRegion.AdvancedFilter _
　　　Action:=xlFilterCopy, _
　　　CriteriaRange:=Sheets("検索").Range("A1:E2"), _
　　　CopyToRange:=Sheets("検索").Range("A5:E65536"), _
　　　Unique:=False
　　Sheets("検索").Select
End Sub
これで抽出はうまくいくのですが、反映する際、
Dim cel As Range
If IsNumeric(Range("A5").Value) And Not IsEmpty(Range("A5").Value) Then
　　　　 Worksheets("リスト").Cells(Range("A5").Value, 1).Resize(1, 26).Value _
　　　　　　 = Range("A5:Z5").Value
　　 Else
　　　　 MsgBox "行番号が？？です"
　　 End If

これですると”リスト”シートが乱れてしまいます。
ご教授願います。

・ツリー全体表示


	【79348】Re:VLOOKUPエラー回避

γ - 17/8/2(水) 21:11 -


	引用なし

	パスワード

解決できたようで何より。

ひとつだけお願いがあります。
今度質問されるときは、逐一、他人の発言を
全文引用するようなことは避けてください。

引用しなくても直ぐ上に表示されているわけですし、
引用してそれについてコメントしているわけでもないですね。
全く無駄です。

・ツリー全体表示


	【79347】Re:VLOOKUPエラー回避

ちゃぷ - 17/8/2(水) 18:48 -


	引用なし

	パスワード

γさん

この度は有難うございました。
勉強になりました。

▼γ さん：
>一行ですむ場合は、そう書くのが決まりだからです。
>ヘルプを読んで下さい。
>If にカーソルを持って行ってF1キーを押します。

・ツリー全体表示


	【79346】Re:VLOOKUPエラー回避

γ - 17/8/2(水) 12:45 -


	引用なし

	パスワード

一行ですむ場合は、そう書くのが決まりだからです。
ヘルプを読んで下さい。
If にカーソルを持って行ってF1キーを押します。

・ツリー全体表示


	【79345】Re:VLOOKUPエラー回避

ちゃぷ - 17/8/2(水) 10:04 -


	引用なし

	パスワード

γさん

お世話になっております。
いつもご丁寧にありがとうございます。
早速、実践したところ上手くいきました。
大変助かりました。

ひとつ質問ですが、下記参考コードで
>If rng Is Nothing Then Exit Sub
に対するend ifが無いのはどうしてでしょうか。
試しに、end ifを入れるとエラーが出てしまいます。
初歩的な質問で申し訳ございませんが、
ご教授の程、宜しくお願い致します。

▼γ さん：
>下記のコードを参考にしてみては？
>
>ポイントは、
>(1)Application.Match はマッチしないとき、エラーで止まらないが、
>　エラー値を返すので、IsError(m) で判定するとよい。
>　 ht tps://www.moug.net/tech/exvba/0100035.html
>　を参考に。
>(2)毎回毎回 Lookupでマッチするかどうか実行するのは無駄。
>　一度だけMatch を実行し、あとは、Indexで取得すればよい。
>　行番号と列番号を使って Cellsで指定しても可。
>　　　
>参考コード：
>
>Private Sub Worksheet_Change(ByVal Target As Range)
>　　Dim myRange As Range
>　　Dim rng　　 As Range
>　　Dim r　　　 As Range
>　　Dim m　　　 As Variant
>
>　　Set rng = Intersect(Target, Range("$G$9:$G$600"))
>
>　　If rng Is Nothing Then Exit Sub
>　　
>　　Application.EnableEvents = False
>　　Set myRange = Sheets("消耗品").Range("$B$3:$L$200")
>
>　　For Each r In rng
>　　　　If r.Value <> "" Then
>　　　　　　m = Application.Match(r, Sheets("消耗品").Range("$B$3:$B$200"), 0)
>　　　　　　If Not IsError(m) Then
>　　　　　　　　r.Offset(, -2).Value = Application.Index(myRange, m, 2)
>　　　　　　　　r.Offset(, -1).Value = Application.Index(myRange, m, 3)
>　　　　　　　　r.Offset(, 1).Value = Application.Index(myRange, m, 4)
>　　　　　　　　' 以下略
>　　　　　　Else
>　　　　　　　　MsgBox r.Value & "　は消耗品シートに該当コードなし"
>　　　　　　　　Application.EnableEvents = True
>　　　　　　　　Exit Sub
>　　　　　　End If
>　　　　Else
>　　　　　　'そのまま残しました。
>　　　　　　r.Offset(, -2).ClearContents
>　　　　　　r.Offset(, -1).ClearContents
>　　　　　　r.Offset(, 1).ClearContents
>　　　　　　r.Offset(, 2).ClearContents
>　　　　　　r.Offset(, 3).ClearContents
>　　　　　　r.Offset(, 4).ClearContents
>　　　　　　r.Offset(, 6).ClearContents
>　　　　　　r.Offset(, 8).ClearContents
>　　　　　　r.Offset(, 12).ClearContents
>　　　　　　r.Offset(, 13).ClearContents
>　　　　End If
>　　Next
>　　Application.EnableEvents = True
>　　Set rng = Nothing
>End Sub

・ツリー全体表示


	【79344】Re:VLOOKUPエラー回避

γ - 17/8/1(火) 23:15 -


	引用なし

	パスワード

下記のコードを参考にしてみては？ポイントは、 (1)Application.Match はマッチしないとき、エラーで止まらないが、　エラー値を返すので、IsError(m) で判定するとよい。　 ht tps://www.moug.net/tech/exvba/0100035.html 　を参考に。 (2)毎回毎回 Lookupでマッチするかどうか実行するのは無駄。　一度だけMatch を実行し、あとは、Indexで取得すればよい。　行番号と列番号を使って Cellsで指定しても可。　　　参考コード： Private Sub Worksheet_Change(ByVal Target As Range) 　　Dim myRange As Range 　　Dim rng　　 As Range 　　Dim r　　　 As Range 　　Dim m　　　 As Variant 　　Set rng = Intersect(Target, Range("$G$9:$G$600")) 　　If rng Is Nothing Then Exit Sub 　　　　Application.EnableEvents = False 　　Set myRange = Sheets("消耗品").Range("$B$3:$L$200") 　　For Each r In rng 　　　　If r.Value <> "" Then 　　　　　　m = Application.Match(r, Sheets("消耗品").Range("$B$3:$B$200"), 0) 　　　　　　If Not IsError(m) Then 　　　　　　　　r.Offset(, -2).Value = Application.Index(myRange, m, 2) 　　　　　　　　r.Offset(, -1).Value = Application.Index(myRange, m, 3) 　　　　　　　　r.Offset(, 1).Value = Application.Index(myRange, m, 4) 　　　　　　　　' 以下略　　　　　　Else 　　　　　　　　MsgBox r.Value & "　は消耗品シートに該当コードなし" 　　　　　　　　Application.EnableEvents = True 　　　　　　　　Exit Sub 　　　　　　End If 　　　　Else 　　　　　　'そのまま残しました。　　　　　　r.Offset(, -2).ClearContents 　　　　　　r.Offset(, -1).ClearContents 　　　　　　r.Offset(, 1).ClearContents 　　　　　　r.Offset(, 2).ClearContents 　　　　　　r.Offset(, 3).ClearContents 　　　　　　r.Offset(, 4).ClearContents 　　　　　　r.Offset(, 6).ClearContents 　　　　　　r.Offset(, 8).ClearContents 　　　　　　r.Offset(, 12).ClearContents 　　　　　　r.Offset(, 13).ClearContents 　　　　End If 　　Next 　　Application.EnableEvents = True 　　Set rng = Nothing End Sub

・ツリー全体表示


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

155 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free