Excel VBA質問箱 IV

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

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


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

178 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【78894】Re:検索し、各シートを検索したセルを表...

HARU - 17/2/21(火) 6:07 -


	引用なし

	パスワード

▼β さん：
色々説明不十分で申し訳ありません。

sheet2はデータの何も入っていないsheetですので、スクロールはしてもしなくても問題ありません。シート数も増減するので全シートを対象にしていました。

ActiveBookは最終的にはマクロブック作成を念頭においております。
まずはThisBOOKで動作させたいと思っています。

>ポイントは以下かな？
>
>　　　　If Not Findcell Is Nothing Then
>　　　　　　On Error Resume Next
>　　　　　　'##移動
>　　　　Else
>　　　　　　ActiveWindow.ScrollRow = Findcell
>　　　　End If
>
>この On Error Resume Next 、これは何を意図して書かれたコードかわかりませんけど
>見つかった場合は On Error Resume Next ??
>見つからなかった場合は Else にいきますよね。
>見つからなかったのにスクロール？
> FindCell は Nothing ですからエラーになるのは当たり前なんですけど？

思い違いをしておりました･･･
IF FindCell が見つからなかったら、
On Error Resume Next
見つかってElseに飛んでサーチのつもりで書いていました

書いていただいたマクロ動かしてみましたが上手く表示されませんでした。
現在、日付の書式がmm"月"dd"日"(aaa)になっております。
書式を変更することも出来ますが、
書いていただいたコードはどの書式で対応しているのでしょうか

・ツリー全体表示


	【78893】Re:検索し、各シートを検索したセルを表...

β - 17/2/20(月) 23:40 -


	引用なし

	パスワード

▼はるさん：

コメントした通り、仕様と要件がいまいち不明ですが、もしかしてやりたかったことは
以下ですか？

Findメソッドで日付を検索する場合、日付のValue(つまり日付型の値）で、LookIn を
xlFormulas にすることがポイントです。

Sub Test()
　　Dim DD As Date
　　Dim Findcell As Range
　　Dim sh As Worksheet
　　
　　DD = Date - 1
　　
　　For Each sh In Worksheets
　　　　Set Findcell = sh.Cells.Find(What:=DD, LookAt:=xlWhole, LookIn:=xlFormulas)
　　　　If Not Findcell Is Nothing Then Application.Goto Findcell.EntireRow.Cells(1), True
　　Next
　　
End Sub

・ツリー全体表示


	【78892】Re:検索し、各シートを検索したセルを表...

β - 17/2/20(月) 23:31 -


	引用なし

	パスワード

▼はるさん：

日付検索は、なかなかやっかいです。
用いる手法（今回の場合はFindメソッド）により、適切な検索方法をとる必要があります。

それ以外のコード記述にも問題が少なくありませんが、それ以前に、仕様が少し、あいまいです。

最初に SHeet2 の A1 に　昨日の日付を入れているわけですが、
その値を元にすべてのシートを処理してますね。
すべてですから、Sheet2 も対象で、つまり、Sheet2 なら、A1 が左上隅になるように
スクロールさせたい？
それとも Sheet2 は対象外？

関係するブックですけど、ActiveWorkbookが登場していますね。
これはマクロブックを意図しておられるのですか？
それとも、別のブックを意図しておられるのですか？

ポイントは以下かな？

　　　　If Not Findcell Is Nothing Then
　　　　　　On Error Resume Next
　　　　　　'##移動
　　　　Else
　　　　　　ActiveWindow.ScrollRow = Findcell
　　　　End If

この On Error Resume Next 、これは何を意図して書かれたコードかわかりませんけど
見つかった場合は On Error Resume Next ??
見つからなかった場合は Else にいきますよね。
見つからなかったのにスクロール？
FindCell は Nothing ですからエラーになるのは当たり前なんですけど？

>▼ウッシさん：
>返信ありがとうございます。
>早速試してみましたが、
>
>上のコード
>実行時エラー５
>プロシージャの呼び出し、または引数が不正です。
>
>下のコード
>実行時エラー91
>オブジェクト変数またはWithブロック変数が設定されていません。
>
>と表示され動きませんでした。
>
>自分の書いたコードのIFが悪さをしているのかと外してみましたが変わらず･･･
>お助けくださいませ

・ツリー全体表示


	【78891】Re:検索し、各シートを検索したセルを表...

はる - 17/2/20(月) 22:46 -


	引用なし

	パスワード

▼ウッシさん：
返信ありがとうございます。
早速試してみましたが、

上のコード
実行時エラー５
プロシージャの呼び出し、または引数が不正です。

下のコード
実行時エラー91
オブジェクト変数またはWithブロック変数が設定されていません。

と表示され動きませんでした。

自分の書いたコードのIFが悪さをしているのかと外してみましたが変わらず･･･
お助けくださいませ

・ツリー全体表示


	【78890】Re:ファイルを更新順に読み込む方法

β - 17/2/20(月) 21:22 -


	引用なし

	パスワード

▼もりC さん：

>objA.MoveFirstのところでコンパイルエラーが発生します。

こちらではコンパイルエラーはでませんが？
エクセルのバージョンは？

それはそれとして、別案。
フォルダ内のcsvファイルを最新更新日順に取り出すサンプルコードです。

Sub Test()
　　Dim fPath As String
　　Dim fName As String
　　Dim sl As Object
　　Dim k As String
　　Dim i As Long
　　
　　Set sl = CreateObject("System.Collections.SortedList")
　　fPath = ThisWorkbook.Path & "\"
　　
　　fName = Dir(fPath & "*.csv")
　　
　　Do While fName <> ""
　　　　k = Format(FileDateTime(fPath & fName), "yyyymmddhhnnss") & " " & fName
　　　　sl.Add k, fPath & fName
　　　　fName = Dir()
　　Loop
　　
　　For i = 0 To sl.Count - 1
　　　　MsgBox sl.getbyindex(i)
　　Next
　　
End Sub

・ツリー全体表示


	【78889】Re:ファイルを更新順に読み込む方法

もりC - 17/2/20(月) 17:58 -


	引用なし

	パスワード

▼ウッシさん

ご回答ありがとうございます。
さっそく下記ソースを試しましたところ、
objA.MoveFirstのところでコンパイルエラーが発生します。
テストで準備したファイルに問題があるのでしょうか。
私自身知識不足なもので、見当違いな質問になっているかもしれません。
ご容赦くださいませ。

具体的に申しますと、処理の順としては、
a.csv
b.csv
c.csv
・
・
・
というファイルがあったとして、それぞれA列、Ｂ列にデータが入っています。
作られた日付の新しい順に、ファイル内A列から特定の文字を順に検索を掛け、
検索で引っかかった場所のB列を返すというマクロになります。

a.csv 読み込み
ファイル内検索
csv ファイルの1.列目(A列)検索　ヒットなし
a.csv ファイル閉じ
↓
b.csv 読み込み
ファイル内検索
csv　ファイルの1.列目(A列)検索　ヒットなし
b.csv ファイル閉じ
↓
c.csv 読み込み
検索ヒット、2.列目（b列）情報取得
検索終わり

というようなプログラムを走らせたくて、
でも、日付順というのがわかりません。

一度に読み込み、別のシートにということも考えましたが、
ファイルの数が多くなると時間もかかると思われ、
何か良い方法はないものかと質問させていただきました。

またよい案がございましたら、ご教授お願いいたします。

▼ウッシさん：
>こんにちは
>
>Sub test()
>　　Dim objF　 As Object
>　　Dim objA　 As Object
>　　Dim fPath　As String
>　　Dim oFile　As Object
>　　
>　　Set objF = CreateObject("Scripting.FileSystemObject")
>　　Set objA = CreateObject("ADODB.Recordset")
>　　objA.Fields.Append "FileName", 200, 300, 32 ', adVarChar, MaxCharacters, adFldIsNullable
>　　objA.Fields.Append "ModifiedDate", 200, 300, 32
>　　objA.Open
>　　fPath = ThisWorkbook.Path
>　　For Each oFile In objF.GetFolder(fPath).Files
>　　　　If oFile Like "*.csv" Then
>　　　　　　objA.AddNew
>　　　　　　objA.Fields(0) = oFile
>　　　　　　objA.Fields(1) = oFile.DateLastModified
>　　　　　　objA.Update
>　　　　End If
>　　Next
>　　objA.Sort = "ModifiedDate ASC"　'昇順
>　　objA.MoveFirst
>　　Do Until objA.EOF
>　　　　'処理Start
>　　　　Debug.Print objA.Fields(1).Value & "----" & objA.Fields(0).Value
>　　　　'処理End
>　　　　objA.MoveNext
>　　Loop
>　　objA.Close
>　　Set objA = Nothing
>　　Set objF = Nothing
>End Sub
>
>一旦読み込ん並べて処理する感じです。

・ツリー全体表示


	【78888】Re:ファイルを更新順に読み込む方法

ウッシ - 17/2/20(月) 14:57 -


	引用なし

	パスワード

こんにちは

Sub test()
　　Dim objF　 As Object
　　Dim objA　 As Object
　　Dim fPath　As String
　　Dim oFile　As Object
　　
　　Set objF = CreateObject("Scripting.FileSystemObject")
　　Set objA = CreateObject("ADODB.Recordset")
　　objA.Fields.Append "FileName", 200, 300, 32 ', adVarChar, MaxCharacters, adFldIsNullable
　　objA.Fields.Append "ModifiedDate", 200, 300, 32
　　objA.Open
　　fPath = ThisWorkbook.Path
　　For Each oFile In objF.GetFolder(fPath).Files
　　　　If oFile Like "*.csv" Then
　　　　　　objA.AddNew
　　　　　　objA.Fields(0) = oFile
　　　　　　objA.Fields(1) = oFile.DateLastModified
　　　　　　objA.Update
　　　　End If
　　Next
　　objA.Sort = "ModifiedDate ASC"　'昇順
　　objA.MoveFirst
　　Do Until objA.EOF
　　　　'処理Start
　　　　Debug.Print objA.Fields(1).Value & "----" & objA.Fields(0).Value
　　　　'処理End
　　　　objA.MoveNext
　　Loop
　　objA.Close
　　Set objA = Nothing
　　Set objF = Nothing
End Sub

一旦読み込ん並べて処理する感じです。

▼もりC さん：
>特定のフォルダ内にある.csvファイルをファイルが更新した順に
>読み込んでいく方法がわかりません。
>
>ファイルを読むには
>　　 pathname = ThisWorkbook.Path
>　　 fname = Dir(pathname & "\*.csv", vbNormal)
>
>などと記述していましたが、これでは名前順でしか対応できません。
>
>どなたかよい方法をご存知でしたら、ご教授ください。

・ツリー全体表示


	【78887】ファイルを更新順に読み込む方法

もりC - 17/2/20(月) 13:32 -


	引用なし

	パスワード

特定のフォルダ内にある.csvファイルをファイルが更新した順に
読み込んでいく方法がわかりません。

ファイルを読むには
　　 pathname = ThisWorkbook.Path
　　 fname = Dir(pathname & "\*.csv", vbNormal)

などと記述していましたが、これでは名前順でしか対応できません。

どなたかよい方法をご存知でしたら、ご教授ください。

・ツリー全体表示


	【78886】Re:検索し、各シートを検索したセルを表...

ウッシ - 17/2/20(月) 8:42 -


	引用なし

	パスワード

追伸

コードの他の部分の動きは確認していません。

・ツリー全体表示


	【78885】Re:検索し、各シートを検索したセルを表...

ウッシ - 17/2/20(月) 8:40 -


	引用なし

	パスワード

こんにちは

ActiveWindow.ScrollRow = Findcell

を

Application.GoTo Findcell, True

か

Application.GoTo Findcell.EntireRow.Cells(1, 1), True

とするとどうですか？

▼はるさん：
>書き込み失礼致します。ご指導よろしくお願いします。
>
>SHEET２に昨日の日付を入力し、他シートでその値で検索、スクロールしたいです。
>見よう見まねで書いてみましたが上手くスクロールしてくれません。
>どのように修正したらいいでしょうか。ご教授願います。
>
>
>Sub サーチ()
>'
>'
>'高速化
>'　 Application.ScreenUpdating = False
>'　 Application.DisplayAlerts = False
>
>'##日付設定
>　　Sheets("Sheet2").Select
>　　Range("A1").FormulaR1C1 = "=TODAY()-1"
>　　Sheets("Sheet2").Range("A1").Value = Sheets("Sheet2").Range("A1").Value
>　　　　
>'##シートループ
>　　Dim i As Integer
>　　Dim DD As String
>　　DD = Range("A1").Value
>　　If ActiveWorkbook.Worksheets.Count < 1 Then Exit Sub
>　　For i = 1 To ActiveWorkbook.Worksheets.Count
>　　Worksheets(i).Select
>　　Range("A1").Select
>　'###日付検索
>　　Dim Findcell As Range
>　　Set Findcell = Cells.Find(what:=DD)
>　 '##無かったら
>　　If Not Findcell Is Nothing Then
>　　On Error Resume Next
>　 '##移動
>　　Else
>　　ActiveWindow.ScrollRow = Findcell
>　　End If
>　　
>　　Next i
>　　
>'　 Application.ScreenUpdating = true
>'　 Application.DisplayAlerts = true
>　　
>　　'
>　　End Sub

・ツリー全体表示


	【78884】検索し、各シートを検索したセルを表示し...

はる - 17/2/20(月) 2:03 -


	引用なし

	パスワード

書き込み失礼致します。ご指導よろしくお願いします。

SHEET２に昨日の日付を入力し、他シートでその値で検索、スクロールしたいです。
見よう見まねで書いてみましたが上手くスクロールしてくれません。
どのように修正したらいいでしょうか。ご教授願います。

Sub サーチ()
'
'
'高速化
'　 Application.ScreenUpdating = False
'　 Application.DisplayAlerts = False

'##日付設定
　　Sheets("Sheet2").Select
　　Range("A1").FormulaR1C1 = "=TODAY()-1"
　　Sheets("Sheet2").Range("A1").Value = Sheets("Sheet2").Range("A1").Value
　　　　
'##シートループ
　　Dim i As Integer
　　Dim DD As String
　　DD = Range("A1").Value
　　If ActiveWorkbook.Worksheets.Count < 1 Then Exit Sub
　　For i = 1 To ActiveWorkbook.Worksheets.Count
　　Worksheets(i).Select
　　Range("A1").Select
　'###日付検索
　　Dim Findcell As Range
　　Set Findcell = Cells.Find(what:=DD)
　 '##無かったら
　　If Not Findcell Is Nothing Then
　　On Error Resume Next
　 '##移動
　　Else
　　ActiveWindow.ScrollRow = Findcell
　　End If
　　
　　Next i
　　
'　 Application.ScreenUpdating = true
'　 Application.DisplayAlerts = true
　　
　　'
　　End Sub

・ツリー全体表示


	【78883】Re:vbcolor code

トキノハジメ - 17/2/19(日) 14:47 -


	引用なし

	パスワード

▼β さん：
早速のご指導有難うございます。

今後とも宜しくお願い致します。

・ツリー全体表示


	【78882】Re:vbcolor code

β - 17/2/19(日) 12:40 -


	引用なし

	パスワード

▼トキノハジメさん：

vbHoge で規定されている色は以下の８色です。

黒(vbBlack)
白(vbWhite)
赤(vbRed)
明るい緑(vbGreen)
青(vbBlue)
黄(vbYellow)
ピンク(vbMagenta)
水色(vbCyan)

そのほかに、新しいエクセル（xl2007　ではどうかわかりませんが）

rgbHoge というものが144個指定可能です。
ただ、これらの中の　灰色関連が　Gray と Grey というスペル両方でＯＫになっていますので
実際の数はそれより少ないですが。
（イギリス人でもアメリカ人でもスペルミスしないような配慮。我々は日本人なんですけどとＭＳに文句言いたいですが）

144個を列挙するのはスペースの関係でやめます。
以下を参照願います。

ht ps://msdn.microsoft.com/ja-jp/library/office/ff197459.aspx

・ツリー全体表示


	【78881】Re:画像貼り付けについて

β - 17/2/19(日) 12:20 -


	引用なし

	パスワード

▼emiko2001 さん：

学校のほうにコメントを入れましたので参照願います。

なお、学校も質問箱も、マルチ許容ですが、それぞれの掲示板として、マルチの場合のルールがあります。

質問箱でいえば、画面の上のほうの　こちら　というバナーをクリックすると見ることができますし
学校の場合も、初めての方へ　というページの中に　マルチ　に関する方針が記載されています。

・ツリー全体表示


	【78880】画像貼り付けについて

emiko2001

- 17/2/19(日) 11:14 -


	引用なし

	パスワード

複数のフォルダがあり、フォルダ内に入っている写真をEXCELに貼り付けて
フォルダごとに保存していくマクロを実行したいと考えています。

フォルダに入っている名前がバラバラの写真jpg(最大６枚)を自動で貼り付ける
マクロを組んでいて、セル【J27】【K27】【L27】【J39】【K39】【L39】に
貼り付けて保存したいと考えています。
色々と調べたりして作成しているのですがうまくいきません。
ご教授宜しくお願いします。
下記がコードです。

Dim fpath As String, fname As String, tname As String
Dim x As Long, y As Long

Application.ScreenUpdating = False
fpath = "C:\"　　　　　　　　　　　　 'CドライブのDフォルダ内
tmpath = fpath & "d\" & (j.Cells(i, 1).Value) & "\"　’セル名前と一致しているファルダ
fname = Dir(tmpath & "*.jpg", vbNormal)
tname = tmpath & fname
y = 10
x = 10

Do Until fname = ""

　If y < 13 Then
　
　s.Cells(27, y).Select
　With s.Pictures.Insert(tname)
.Left = Selection.Left
.Top = Selection.Top
.Width = Selection.Width
.Height = Selection.Height
　End With
　y = y + 1

Else
　
　s.Cells(39, x).Select
　With s.Pictures.Insert(tname)
.Left = Selection.Left
.Top = Selection.Top
.Width = Selection.Width
.Height = Selection.Height
　 End With
　x = x + 1
　End If
　
　fname = Dir()
　
Loop

'Next x
　Application.ScreenUpdating = True

　w.SaveAs (p & "\E\" & j.Cells(i, 1).Value & ".xlsx")　’Eフォルダに名前をつけてxlsxで保存
　w.Close
Next i

宜しくお願いします。

・ツリー全体表示


	【78879】vbcolor code

トキノハジメ - 17/2/19(日) 10:54 -


	引用なし

	パスワード

いつもお世話になります。

VBColor コードを教えて下さい。

vbRed.vbGreen.vbRed等はわかりますが、橙色、茶色等、他にどんな色表記があるのか教えて下さい。

・ツリー全体表示


	【78878】Re:２シートの一致照合と計算、一致項目...

まるばつ - 17/2/18(土) 10:25 -


	引用なし

	パスワード

▼β 様：

早速のお返事およびプログラミングありがとうございます。
マクロ実行をしてみたところ、見事私の理想通りの動きをしました！

今まで手でしていた作業の大幅な効率化ができると思うと
とてもうれしく思います。

この度はすべて丸投げをしてしまいましたがまず、このマクロの理解から
VBAを始めてみようと思います。

ありがとうございました！

・ツリー全体表示


	【78877】Re:worksheetのコピー貼り付け

のんぼ - 17/2/18(土) 7:53 -


	引用なし

	パスワード

▼γ さん：
>修正すべき最大のものは、
>>・検索対象のシートが特定されていない。
>のところです。
>
>標準モジュールに書かれたプロシージャで、
>シート名が省略されると、現在アクティブなシートが前提とされます。
>ループ内の後半で、"請求書鑑"がアクティブにされていますから、
>次の検索処理では、そのシートのなかを検索してしまうことになります。
>
>こういったことを頭に置いて、
>コードに手を入れてください。
>
>もう完成しているなら良いけれど、そうでないならQ/Aを続けたらどうかと。
返礼遅れまして申し訳ありません。
いろいろアドバイスをいただきまして、大変ありがとうございます。勉強になりました。参考にさせていただき、勉強するように努力いたします。
本当にありがとうございました。

・ツリー全体表示


	【78876】Re:２シートの一致照合と計算、一致項目...

β - 17/2/17(金) 19:47 -


	引用なし

	パスワード

▼まるばつさん：

改訂版です。

Sub Sample()
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim sh3 As Worksheet
　　Dim i As Long
　　Dim mx As Long
　　Dim k As String
　　Dim z As Variant
　　Dim n1 As Long
　　Dim n2 As Long
　　Dim r As Range
　　
　　Application.ScreenUpdating = False
　　
　　Set sh1 = Sheets("Sheet1")
　　Set sh2 = Sheets("Sheet2")
　　Set sh3 = Sheets("Sheet3")
　　
　　mx = sh1.Range("A" & Rows.Count).End(xlUp).Row　'Sheet1 の最終セルの行番号
　　
　　For i = 2 To mx '２行目から最終行までを繰り返し処理
　　　　k = sh1.Cells(i, "C").Value　　 'その行のC列の値
　　　　If Not IsEmpty(k) Then　'空白の値でなければ
　　　　　　Set r = sh2.Range("C1", sh2.Range("C" & Rows.Count).End(xlUp))
　　　　　　z = Application.Match(k, r, 0)　　 'その値がSHeet2のC列にあるかどうか
　　　　　　If IsNumeric(z) Then　　'あった
　　　　　　　　sh1.Cells(i, "D").Value = sh1.Cells(i, "D").Value - sh2.Cells(z, "D").Value　　 'D列のセル Sheet1-Sheet2
　　　　　　　　sh1.Cells(i, "E").Value = sh1.Cells(i, "E").Value - sh2.Cells(z, "E").Value　　 'E列のセル Sheet1-Sheet2
　　　　　　　　sh1.Rows(i).Copy sh3.Range("A" & Rows.Count).End(xlUp).Offset(1)　　　　　　　　'この時点のSheet3の最終行の次の行に追加
　　　　　　　　sh1.Rows(i).ClearContents　'Sheet1の該当行をクリア
　　　　　　　　sh2.Rows(z).ClearContents　'SHeet2の該当行をクリア
　　　　　　End If
　　　　End If
　　Next
　　
End Sub

・ツリー全体表示


	【78875】Re:２シートの一致照合と計算、一致項目...

β - 17/2/17(金) 19:37 -


	引用なし

	パスワード

▼まるばつさん：

あっあっあっ！！

最初行削除でコードを書いて、アップ前にクリアにしたんですが、クリアの場合
アップしたコードでは具合悪くなります。

改訂版、後ほどアップします。

・ツリー全体表示


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

178 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free