Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
114 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
【80188】Re:マクロ初心者で、初歩的な質問です。
発言  よろずや  - 18/10/15(月) 14:04 -
引用なし
パスワード
   ▼usimaru さん：
>Range("F2").AutoFilter Field:=6, Criteria1:=Range("F2").Value
>
>※フィルター条件は、Ｆ２データを元に左から6列目の同様のデータ（あいうえお）抽出したいのですが。

テーブルの範囲はどうなってますか？
A1〜F1に見出し、A2〜F2以降にデータがあるなら、間違ってはいません。
・ツリー全体表示
【80187】コードの最適化(取得したセル値をヘッダ...
質問  閣下  - 18/10/15(月) 13:06 -
引用なし
パスワード
   はじめまして。

ファイルを閉じる時に
・指定したシートのあるセルの内容を、ヘッダーの左上に入れる
・ブック全体でページ番号/総ページ数を右上に入れる

マクロを作成し、動くことは動くのですがファイルを閉じる際に若干もっさりします。
2つの処理をまとめればもう少し軽くなるのかなと思いつつ弄っていますが、うまくいきません。申し訳ありませんが最適化したコードの例をご教示いただけますでしょうか。

'ファイルclose時に以下の処理をする
Private Sub Workbook_BeforeClose(Cancel As Boolean)
　　Dim s As Worksheet
　　For Each s In ThisWorkbook.Sheets
　　　　'左上ヘッダーにaaシートB3セルの値を表示
　　　　With s.PageSetup
　　　　　　.LeftHeader = Worksheets("aa").Range("B3").Value
　　　　End With
　 Next

　　'右上ヘッダーに"ドキュメント全体でのページNo/総ページ数"を表示
　　Dim Cnt As Integer
　　Dim n　　As Integer
　　Cnt = ActiveWorkbook.Worksheets.Count
　　
　　For n = 1 To Cnt
　　　　With Worksheets(n).PageSetup
　　　　　　.RightHeader = "(" & n & "/" & Cnt & ")"
　　　　　　.FirstPageNumber = 1
　　　　End With
　　Next n
End Sub
・ツリー全体表示
【80186】Re:マクロ初心者で、初歩的な質問です。
発言  マナ  - 18/10/15(月) 12:48 -
引用なし
パスワード
   ▼usimaru さん：

Columns("F").AutoFilter Field:=1, Criteria1:=Range("F2").Value

これでてきませんか
・ツリー全体表示
【80185】マクロ初心者で、初歩的な質問です。
質問  usimaru  - 18/10/15(月) 0:58 -
引用なし
パスワード
   分からないので質問させてください。

Ｆ２セルに入力されてるデータ　例）あいうえお　と入力されているとします。
それを元にオートフィルターを実行したいのですが、以下は何が間違っているのでしょうか。


Range("F2").AutoFilter Field:=6, Criteria1:=Range("F2").Value

※フィルター条件は、Ｆ２データを元に左から6列目の同様のデータ（あいうえお）抽出したいのですが。

ご教示いただけないでしょうか。
・ツリー全体表示
【80184】Re:文字数が2以上のセルを左上揃え、2未...
お礼  困り人  - 18/10/13(土) 17:18 -
引用なし
パスワード
   ▼γ さん：

わかりました。ありがとうございます！
>速度については、必要な属性だけに限定するとかでしょうか？
>
>あと考えるべきは、実行のタイミングでしょう。
>入力が終わったあとで一括して処理すればいいのか、
>リアルタイムに変更させたいかですね。
>後者なら、Excel付属の条件付き書式が本来的な対応ですね。
・ツリー全体表示
【80183】Re:文字数が2以上のセルを左上揃え、2未...
発言  γ  - 18/10/13(土) 17:08 -
引用なし
パスワード
   速度については、必要な属性だけに限定するとかでしょうか？

あと考えるべきは、実行のタイミングでしょう。
入力が終わったあとで一括して処理すればいいのか、
リアルタイムに変更させたいかですね。
後者なら、Excel付属の条件付き書式が本来的な対応ですね。
・ツリー全体表示
【80182】Re:文字数が2以上のセルを左上揃え、2未...
発言  困り人  - 18/10/13(土) 15:43 -
引用なし
パスワード
   ▼γ さん：
For Each ...Nextを使ったらできた気がします。
ありがとうございます。
結構時間がかかってしまうのは仕方がないですかね？

Sub Macro1()
Dim c As Range
　　For Each c In Selection
　　　　If Len(c) > 1 Then
　　　　　　With c
　　　　　　　　.HorizontalAlignment = xlLeft
　　　　　　　　.VerticalAlignment = xlTop
　　　　　　　　.WrapText = False
　　　　　　　　.Orientation = 0
　　　　　　　　.AddIndent = False
　　　　　　　　.IndentLevel = 0
　　　　　　　　.ShrinkToFit = False
　　　　　　　　.ReadingOrder = xlContext
　　　　　　　　.MergeCells = False
　　　　　　End With
　　　　
　　　　 Else
　　　　　　With c
　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　　　.VerticalAlignment = xlCenter
　　　　　　　　.WrapText = False
　　　　　　　　.Orientation = 0
　　　　　　　　.AddIndent = False
　　　　　　　　.IndentLevel = 0
　　　　　　　　.ShrinkToFit = False
　　　　　　　　.ReadingOrder = xlContext
　　　　　　　　.MergeCells = False
　　　　　　End With
　　　　 End If
　　Next c
End Sub

>条件付き書式で対応可能ですが、
>あえてマクロなんですね？
>
>詰まっているのはどこですか？
>まず1セルではできますか？
>文字列の長さはLen関数です。
>書式変更はマクロ記録を活用してください。
>
>選択範囲のそれぞれに対して実行するには
>For Each ...Next を使います。
・ツリー全体表示
【80181】Re:文字数が2以上のセルを左上揃え、2未...
発言  γ  - 18/10/13(土) 15:02 -
引用なし
パスワード
   条件付き書式で対応可能ですが、
あえてマクロなんですね？

詰まっているのはどこですか？
まず1セルではできますか？
文字列の長さはLen関数です。
書式変更はマクロ記録を活用してください。

選択範囲のそれぞれに対して実行するには
For Each ...Next を使います。
・ツリー全体表示
【80180】文字数が2以上のセルを左上揃え、2未満の...
質問  困り人  - 18/10/13(土) 13:40 -
引用なし
パスワード
   選択範囲のうち、文字数が2以上のセルを左上揃え、2未満のセルを中央揃えにする
マクロはどう作成すればよいでしょうか？
・ツリー全体表示
【80179】Re:部課ごとに各項目で集計したい
発言  名木  - 18/10/10(水) 9:59 -
引用なし
パスワード
   ▼マナ さん：
>▼名木 さん：
>
>>ピボットテーブルでの集計であれば、毎回手入力で
>>出来ますが、まだ先にある道程を考えて、ここは
>>自動化したいと考えたのです。
>
>ピボットテーブルであれば、
>２回めからは、更新ボタンをクリックするだけで
>自動で集計やり直してくれますよ。
>
>マクロ実行ボタンをクリックするのと手間は変わらないのでは？

ピボットの更新でレコード数が増えたりした場合
のデータ範囲の変更も更新されるとは知りませんでした。
自動で範囲を認識しなおすことが出来るのですね。
それであれば、同じことかもしれませんね。
・ツリー全体表示
【80178】Re:部課ごとに各項目で集計したい
発言  マナ  - 18/10/9(火) 18:54 -
引用なし
パスワード
   ▼名木 さん：

>ピボットテーブルでの集計であれば、毎回手入力で
>出来ますが、まだ先にある道程を考えて、ここは
>自動化したいと考えたのです。

ピボットテーブルであれば、
２回めからは、更新ボタンをクリックするだけで
自動で集計やり直してくれますよ。

マクロ実行ボタンをクリックするのと手間は変わらないのでは？
・ツリー全体表示
【80177】Re:部課ごとに各項目で集計したい
発言  名木  - 18/10/9(火) 8:51 -
引用なし
パスワード
   ▼マナ さん：
>▼名木 さん：
>
>集計シートのレイアウトがわかりません
>どのような結果を期待されていますか
社員部課ごとの所得税以下の項目を
集計させるマクロを考えています。

>提示されたマクロは何か関係ありますか
途中までほかのサイトなどで調べマクロで書いてみましたが、
何が一番シンプルで分かりやすいのか考えているうちに
途方にくれ、質問した次第です。
>
>ピボットテーブルでの集計は検討してみましたか
ピボットテーブルでの集計であれば、毎回手入力で
出来ますが、まだ先にある道程を考えて、ここは
自動化したいと考えたのです。
・ツリー全体表示
【80176】Re:部課ごとに各項目で集計したい
発言  マナ  - 18/10/6(土) 18:40 -
引用なし
パスワード
   ▼名木 さん：

集計シートのレイアウトがわかりません
どのような結果を期待されていますか
提示されたマクロは何か関係ありますか

ピボットテーブルでの集計は検討してみましたか
・ツリー全体表示
【80175】Re:VBA Do Loop Untilでエラー
発言  γ  - 18/10/6(土) 17:22 -
引用なし
パスワード
   内部的な処理の話なので正確なことは不明だが、
再帰処理が関係していると想像。
いわゆる末尾再帰となる書き方(エラーが
でない方の書き方)が推奨されるということでしょう。
・ツリー全体表示
【80174】部課ごとに各項目で集計したい
質問  名木  - 18/10/6(土) 14:55 -
引用なし
パスワード
   人事シートをもとに、社員部課別で指定した項目の集計をしたいと
思います。
シンプルで分かりやすいマクロを教えていただけないでしょうか？
結果を示すシートは[集計シート]とします。

Option Explicit

Sub ColCopy()
　　Dim xlBook As Workbook
　　Dim xlSheetOrg As Worksheet
　　Dim xlSheetSel As Worksheet
　　Dim xlSheetDst As Worksheet
　　Dim strDstSheetName As String
　　Dim rngLastRow As Range
　　Dim vntIndex As Variant
　　Dim rngIndexs As Range
　　Dim rngHeader As Range
　　Dim lngColSrc As Long
　　Dim lngColDst As Long
　　Dim rngTargetCol As Range
　　
　　
　　Set xlBook = ThisWorkbook
　　
　　With xlBook
　　　　Set xlSheetSel = .Worksheets("指定")
　　　　Set xlSheetOrg = .Worksheets("人事")
　　End With
　　
　　' コピー先シート名取得
　　strDstSheetName = xlSheetSel.Range("A2").Value
　　
　　' コピー先シートを初期化（なければ生成）
　　On Error GoTo ERR_DST_SHEET
　　Set xlSheetDst = xlBook.Worksheets(strDstSheetName)
　　With xlSheetDst
　　　　.Cells.Clear
　　End With
　　On Error GoTo 0
　　
　　
　　' 項目名を読み取り
　　With xlSheetSel
　　　　Set rngLastRow = .Cells(.Rows.Count, 1).End(xlUp)
　　　　Set rngIndexs = .Range(.Cells(21, 1), rngLastRow)
　　　　Set rngLastRow = Nothing
　　End With
　　
　　' 見出し行の取り込み
　　Set rngHeader = xlSheetOrg.Rows(1)
　　
　　' 該当列のコピー
　　Application.ScreenUpdating = False
　　With xlSheetDst
　　　　lngColDst = 0
　　　　For Each vntIndex In rngIndexs
　　　　　　lngColDst = lngColDst + 1
　　　　　　Set rngTargetCol = rngHeader.Find(CStr(vntIndex))
　　　　　　lngColSrc = rngTargetCol.Column
　　　　　　rngTargetCol.EntireColumn.Copy .Cells(1, lngColDst)
　　　　　　Set rngTargetCol = Nothing
　　　　Next vntIndex
　　　　Set rngIndexs = Nothing
　　End With
　　Application.ScreenUpdating = True
　　
　　GoTo PROC_END
　　
ERR_DST_SHEET:
　　Set xlSheetDst = Sheets.Add(, Sheets("集計"))
　　xlSheetDst.Name = strDstSheetName
　　Resume Next
　　
PROC_END:
　　Set rngHeader = Nothing
　　Set xlSheetDst = Nothing
　　Set xlSheetOrg = Nothing
　　Set xlSheetSel = Nothing
　　Set xlBook = Nothing

End Sub

[人事シート]
　A　　　　　　B　　　　　　　　　C　　　　　　　D　　　　　　　E　　　　　　　　F　　　　G　　　　
1社員氏名　 社員部課 　　　社員体系 平日出勤 休日出勤 出勤時間 残業手当Ａ
2京都　太郎 パートフロアー パート　　　　　　　　　　　　　　　　　　　　
3山田　山太　生産　　　　　 社員　　　　　　　　　　　　　　　　　　　　
4木本　樹 　フロアー　　　　　　社員　　　　　　　　　　　　　　　　　　　　


[指定シート]
　　　　A列
1　　　　集計先
2　　　　集計
3　　　　
4　　　　項目名
5　　　　社員氏名
6　　　　社員部課
7　　　　社員体系
8　　　　支給合計
9　　　　所得税
10　　　　課税通勤手当
11　　　　非課税通勤手当
12　　　　時間外Ａ金額
13　　　　時間外Ｂ金額
14　　　　時間外Ｃ金額
15　　　　時間外Ｄ金額
16　　　　健康保険料(一般)
17　　　　健康保険料(介護)
18　　　　厚生年金保険料
19　　　　雇用保険料
20　　　　住民税
21　　　　控除項目４
22　　　　控除項目５
・ツリー全体表示
【80173】Re:VBA Do Loop Untilでエラー
発言  γ  - 18/10/6(土) 11:44 -
引用なし
パスワード
   時間がとれたので内容を見てみました。
下記の例で、エラーとなりますね。
そもそもですが、Loop処理の中で再帰呼び出しは不可避なんでしょうか？
何をしようとされているか説明が無いのでよくわかりませんが。

理由は不明ですが、
記法によってエラーが避けられるならそれに従うのがよろしいかと。

Sub test()
　　[H1:H5].Value = Application.Transpose(Array(1, 2, 3, 5, 1)) 'データ設定
　　Call 支(1, False, 1)　　'エラーとならない
End Sub

Sub test2()
　　[H1:H5].Value = Application.Transpose(Array(1, 2, 3, 5, 1))　'データ設定
　　Call 支2(1, False, 1)　 '「式が複雑すぎます」というエラーとなる
End Sub

Function 支(ByRef currentRow As Long, ByVal flag As Boolean, ByVal 列 As Byte)
　　Dim myLevel As Byte
　　Dim I_Flag As Boolean

　　With ActiveSheet
　　　　myLevel = Val(.Range("H" & currentRow))
　　　　Do Until myLevel > Val(.Range("H" & currentRow))
　　　　　　
　　　　　　' ここで作業
　　　　　　
　　　　　　currentRow = currentRow + 1
　　　　　　If myLevel < Val(.Range("H" & currentRow)) Then Call 支(currentRow, I_Flag, 列)
　　　　Loop
　　End With
End Function

Function 支2(ByRef currentRow As Long, ByVal flag As Boolean, ByVal 列 As Byte)
　　Dim myLevel As Byte
　　Dim I_Flag As Boolean

　　With ActiveSheet
　　　　myLevel = Val(.Range("H" & currentRow))
　　　　Do
　　　　　　
　　　　　　' ここで作業
　　　　　　
　　　　　　currentRow = currentRow + 1
　　　　　　If myLevel < Val(.Range("H" & currentRow)) Then Call 支2(currentRow, I_Flag, 列)
　　　　Loop Until myLevel > Val(.Range("H" & currentRow))
　　End With
End Function
・ツリー全体表示
【80172】Re:ソルバーにてエラー”1004”が出て困...
発言  γ  - 18/10/5(金) 7:03 -
引用なし
パスワード
   最後の部分は私の勘違いでした。取り消します。

再現できる情報が無いので、私には不明です。
他の方の回答をお待ちください。
・ツリー全体表示
【80171】Re:VBA Do Loop Untilでエラー
発言  γ  - 18/10/4(木) 19:23 -
引用なし
パスワード
   スマフォで見ているので詳細わかりませんが
エラー時の関連する変数の値を教えてください。
・ツリー全体表示
【80170】Re:ソルバーにてエラー”1004”が出て困...
発言  γ  - 18/10/4(木) 19:15 -
引用なし
パスワード
   悪いけど意味が理解できません。
何回もSolveを実行しているけど、
それらの条件は重なっていくのではなく
独立ですよ。
そして各単位では変数が多い割に
条件が少ないので、
いわゆる不定になっていると思われる。
・ツリー全体表示
【80169】Re:VBA Do Loop Untilでエラー
お礼  まよい人  - 18/10/4(木) 15:54 -
引用なし
パスワード
   γ 様

ありがとうございます。
仰る通りです。

エラーが生じるコードは

Function 支(ByRef currentRow As Long, ByVal flag As Boolean, ByVal 列 As Byte)
　　With ActiveSheet
　　Dim myLevel As Byte
　　myLevel = Val(.Range("H" & currentRow))
　　Do
　　　　Dim I_Flag As Boolean
　　　　I_Flag = CStr(.Range("Q" & currentRow)) = "380"
　　　　If Not I_Flag Then
　　　　　　If flag Then
　　　　　　　　Set ss = Me.Range("E3:E453").Find(Left(.Range("F" & currentRow), 13), LookIn:=xlValues, LookAt:=xlPart)
　　　　　　　　If ss Is Nothing Then Set ss = Me.Range("E3:E453").Find(Left(.Range("F" & currentRow), 11) & "X" & Mid(.Range("F" & currentRow), 13, 1))
　　　　　　　　I_Flag = ss Is Nothing
　　　　　　　　If Not I_Flag Then I_Flag = Me.Cells(ss.Row, 列) = ""

　　　　　　　　If Not I_Flag Then
　　　　　　　　　　If Left(.Range("K" & currentRow), 1) <> "ﾑ" Then
　　　　　　　　　　　　.Range("K" & currentRow) = "ﾑ←" & .Range("K" & currentRow)
　　　　　　　　　　　　.Range("K" & currentRow).Interior.ColorIndex = 33
　　　　　　　　　　End If
　　　　　　　　ElseIf Left(.Range("K" & currentRow), 2) <> "ｼﾞ" Then
　　　　　　　　　　.Range("K" & currentRow) = "ｼﾞ←" & .Range("K" & currentRow)
　　　　　　　　　　.Range("K" & currentRow).Interior.ColorIndex = 33
　　　　　　　　End If
　　　　　　End If
　　　　ElseIf Left(.Range("K" & currentRow), 2) <> "ｼﾞ" Then
　　　　　　.Range("K" & currentRow) = "ｼﾞ←" & .Range("K" & currentRow)
　　　　　　.Range("K" & currentRow).Interior.ColorIndex = 33
　　　　End If
　　　　currentRow = currentRow + 1

　　　　If myLevel < Val(.Range("H" & currentRow)) Then Call 支(currentRow, I_Flag, 列)
　　Loop Until myLevel > Val(.Range("H" & currentRow))
　　End With
End Function

です。
・ツリー全体表示
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
114 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free