Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
179 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
【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 E-MAIL  - 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 -
引用なし
パスワード
   ▼まるばつ さん：

あっあっあっ！！

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

改訂版、後ほどアップします。
・ツリー全体表示
【78874】Re:２シートの一致照合と計算、一致項目...
発言  β  - 17/2/17(金) 19:34 -
引用なし
パスワード
   ▼まるばつ さん：

↑　要件がクリアではなく削除になっても対応しやすいようにしましたが
クリアでかわらないということなら

　　For i = mx To 2 Step -1 '最終行から２行目までを繰り返し処理

これを

　　For i = 2 To mx '２行目から最終行までを繰り返し処理

のほうが素直でいいです。
・ツリー全体表示
【78873】Re:２シートの一致照合と計算、一致項目...
発言  β  - 17/2/17(金) 19:31 -
引用なし
パスワード
   ▼まるばつ さん：

Sheet2 の最終行　456 GHI の C列が 456DEF になっているのは　456GHI の間違いだとして。

効率化を求めれば、もっと複雑なコード記述になりますが、ＶＢＡが、あまり得意ではない
ということなので、１行ずつ　２つのシートをシート関数のMATCH で比較して処理しています。

『削除』ということですが、質問内の結果サンプルでは『クリア』ですので
以下のコードでも行削除ではなく、行のクリアにしています。

掲示板上、コードが改行されてみにくいのですが、モジュールにコピペすれば
見やすくなると思います。

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

　　
　　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 = mx To 2 Step -1 '最終行から２行目までを繰り返し処理
　　　　k = sh1.Cells(i, "C").Value　　 'その行のC列の値
　　　　z = Application.Match(k, sh2.Range("A1").CurrentRegion.Columns("C"), 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
　　Next
　　
End Sub
・ツリー全体表示
【78872】２シートの一致照合と計算、一致項目の削...
質問  まるばつ  - 17/2/17(金) 18:36 -
引用なし
パスワード
   初めて質問させていただきます。私は関数は少々わかるもののVBAがさっぱりなので
インターネットで検索していたところここを見つけました。


シート1に


　　　A　　　　　　　B　　　　　　C　　　　E　　F　　G〜Z
1　伝票番号　型番　A＆B　　個数　金額　項目色々
2　123　　　ABC　　123ABC　　2　 2000
3　123　　　DEF　　123DEF　　4　 8000
4　456　　　ABC　　456ABC　　1　 1000
5　456　　　GHI　　456GHI　　2　 6000
6　456　　　DEF　　456DEF　　3　 6000

シート2に

　　　A　　　　　　　B　　　　　　C　　　　E　　F　　G〜Z
1　伝票番号　型番　A＆B　　個数　金額　項目色々
2　123　　　DEF　　123DEF　　4　 8000
3　456　　　GHI　　456GHI　　1　 3000
4　456　　　GHI　　456DEF　　3　 6000

というエクセルの表があります。

シート1の列C（A&B）をシート2の列C（A&B）と照会し、一致するものがあれば
引き算（シート1　―　シート2）をして、新しシートに書き込みをしてシート1と2から削除するマクロを
教えて頂きたいと思っております。
マクロを実行するたびにシート3に追記できる形でお願いします。

結果として

シート1に


　　　A　　　　　　　B　　　　　　C　　　　E　　F　　G〜Z
1　伝票番号　型番　A＆B　　個数　金額　項目色々
2　123　　　ABC　　123ABC　　2　 2000
3　
4　456　　　ABC　　456ABC　　1　 1000
5　
6　456　　　DEF　　456DEF　　3　 6000

シート2に

　　　A　　　　　　　B　　　　　　C　　　　E　　F　　G〜Z
1　伝票番号　型番　A＆B　　個数　金額　項目色々
2　
3　
4　456　　　GHI　　456DEF　　3　 6000

シート3に

　　　A　　　　　　　B　　　　　　C　　　　E　　F　　G〜Z
1　伝票番号　型番　A＆B　　個数　金額　項目色々
2　123　　　DEF　　123DEF　　0　 0
3　456　　　GHI　　456GHI　　1　 3000
4　


となるようなことをマクロでできるのでしょうか？
できるならどんなプログラムになるのか教えて頂きたいと思います。
どうかよろしくお願いします。
・ツリー全体表示
【78870】Re:フラグが立つ全通りの表示
発言  γ  - 17/2/14(火) 23:51 -
引用なし
パスワード
   実行したいことを端的に説明したほうがよいでしょう。
配列などを上手く使って、繰り返し計算をするということですね。

籤だとか余計な話を入れないほうがよい。
まあ、コードを作るということは、機械に向かって説明するということですよ。
人間に向かって説明が難しいなら、
機械にはさらに理解してもらえないでしょう。
・ツリー全体表示
【78869】Re:フラグが立つ全通りの表示
お礼  あらけい  - 17/2/14(火) 23:42 -
引用なし
パスワード
   回答ありがとうございます

>別に上のような表を書くこと自体が
>最終的な目標ではないんでしょうかねえ。
>もう少し実行したいことを明確に書いて欲しい。

最終的な目的はこのフラグを使って計算をおこない
もっとも高い値が出る並びを知りたいことです。

言葉足らずで申し訳ございません。

まさに、おこないたかったことができました。
ありがとうございます。

これを基に、３回だけでなく複数回おこなったときの
プログラムを考えたいと思います。

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