ここから本文です

マクロ初心者です。 朝方に質問し、自分なりにネット検索して似たものを加工し...

sho********さん

2018/4/718:24:04

マクロ初心者です。

朝方に質問し、自分なりにネット検索して似たものを加工してプログラムを組みました。まだまだ不完全で解決できない問題があり、アドバイスをいただきたく、よろしくお願いします。

特に課題として残っているのが以下の点です
・欠落のある限定された期間(下記 ●やりたいこと の②‐③)のみを抜き出す

--------------
●やりたいこと
【前提】
特定の名称に毎日の日付が付いたファイル、例えば"○○○20180407×××.xlsx"があり、その中の"△△△"シートの中に複数の商品についてC列からI列まで必要な情報があります。
A商品 C2~I2
B商品 C3~I3
C商品 C4~I4
商品については改廃があり、A商品の位置が常に2行目ということはありません。
※日曜など日付が欠落しいるファイルがあります。

【目的】
別ファイルに以下を指定
①商品名 A1
②始まりの日付 B1
③終りの日付 B2

A1に入力された商品名のB1からB2までの期間のC列からI列までの一覧表を作成したい
---------------

●ネットを参考に組んでみたプログラム
Const myPath As String = "保存先フォルダ"
Dim rIdx As Long
Dim fName As String
Dim pName As String
Dim pIdx As Long

pName = Range("A1").Value

fName = Dir(myPath & "○○○*×××.xls")

rIdx = 1

Do Until fName = ""
Workbooks.Open Filename:=myPath & fName
pIdx = WorksheetFunction.Match(pName, Range("F1:F1000"), 0)
rIdx = rIdx + 1

Workbooks(fName).Sheets("△△△").Range(Cells(pIdx, 3), Cells(pIdx, 9)).Copy
Windows("排出ファイル名).Activate
Range(Cells(rIdx, 2), Cells(rIdx, 2)).Select
ActiveSheet.Paste

Cells(rIdx, 1).Value = fName
Windows(fName).Close
fName = Dir
Loop

閲覧数:
86
回答数:
2
お礼:
25枚

違反報告

ベストアンサーに選ばれた回答

プロフィール画像

カテゴリマスター

kky********さん

2018/4/809:36:43

マクロを入れるブックと「別ファイルに以下を指定」という別ファイルとは別なのですか?コードの中の「"排出ファイル名」というのがよくわかりません。

下記は
マクロを入れるブックの最初のシートに
①商品名 A1
②始まりの日付 B1
③終りの日付 B2
の情報があるとしています。
2行目まで検索条件が入っているので、3行目以降に検索結果を入れていきます。

変数名はなるべく同じものを使いました。

Sub sho_0408()
Const myPath As String = "保存先フォルダ"
Dim fName As String
Dim pName As String
Dim wb As Workbook
Dim sh As Worksheet
Dim rIdx As Long
Dim pIdx As Variant
Dim sdate As String, edate As String
Dim tmp As Date
Application.ScreenUpdating = False
Set sh = ThisWorkbook.Worksheets(1)
With sh
pName = .Range("A1").Value
sdate = .Range("B1").Value
edate = .Range("B2").Value
End With
fName = Dir(myPath & "\○○○" & "*.xlsx")
rIdx = 2
Do Until fName = ""
'日付範囲チェック
tmp = DateSerial(Mid(fName, 4, 4), Mid(fName, 8, 2), Mid(fName, 10, 2))
If tmp >= sdate And tmp <= edate Then
Set wb = Workbooks.Open(myPath & "\" & fName)
With wb.Worksheets("△△△")
pIdx = Application.Match(pName, .Range("F1:F" & .Cells(Rows.Count, "F").End(xlUp).Row), 0)
If IsError(pIdx) = False Then
rIdx = rIdx + 1
.Range("C" & pIdx & ":H" & pIdx).Copy Destination:=sh.Range("B" & rIdx)
sh.Range("A" & rIdx).Value = fName
End If
End With
wb.Close
End If
fName = Dir()
Loop
Application.ScreenUpdating = True
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

質問した人からのコメント

2018/4/9 12:00:42

中途半端な返答申し訳ありません。何がエラーか理解したかったのですが、エラーの原因が特定できない以上、どうしようもありませんね。
本当にありがとうございました。

ベストアンサー以外の回答

1〜1件/1件中

hig********さん

2018/4/719:18:10

ファイルを開く前に、期間内か否か判別することになります。ファイル名から日付部分を取り出し、B1<xDate<B2かどうか調べます。

const SpecialName as string ="◯◯◯"
dim xDate as date
dim Date1 as date, Date2 as Date
Date1= cdate(range("B1"))
Date2= cdate(range("B2"))

xDate=cdate(mid(fName,len(SpecialName)+1, 8)) 'ファイル名から日付を取り出す
if Date1<= xDate & xDate <= Date2 then
'日付が合う場合の処理つまりファイル開いて処理して閉じるまで
end if

テストしてないので、間違えたらゴメン

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる