ここから本文です

Excel VBAでご教授下さい。

アバター

ID非公開さん

2019/4/1623:35:56

Excel VBAでご教授下さい。

以下の事をVBAで行なえたらと思います。

集計データbookのSheet1A8~A39に
2019/1/21~2019/2/20までの日付けがあります

マスターデータbookのSheet2 A2に以下に2019/1/1~今日までの日付があります(この日付は増えて行きます)

【マクロは集計データbookで実施】

①Desktopにあるマスターデータbook Sheet2を開き
②A2以下の日付の中から
集計データbookのsheet1 A8~A39と
同じ日付のG列にある値をコピーし
③集計データbook B8~B39に転記(値のみ貼付け)
④転記後はマスターデータbookを保存無しで閉じる

このコードを教えて頂けないでしょうか。
何卒宜しくお願い致します。

閲覧数:
69
回答数:
2
お礼:
50枚

違反報告

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

jiy********さん

2019/4/1711:14:01

日付の検索の方法はデータの種類によって変わってきますが、シリアル値(数式の結果としてのシリアル値を含む)を日付形式で表示している場合は以下でできるかと思います。

コード中にFindを使っています。Findはワークシート上で使う検索・置換ダイアログと連動しているので、マクロを実行すると検索条件の設定が変わってしまうことが考えられるので注意してください。

Sub sample()
    Dim fd As String, fn As String
    Dim wbM As Workbook, shM As Worksheet, shS As Worksheet
    Dim irow As Long, fnd As Range
    Dim opnFlg As Boolean
    
    fn = "マスターデータbook.xlsx"
    With CreateObject("WScript.Shell")
        fd = .SpecialFolders("Desktop")
    End With
    On Error Resume Next
    Set wbM = Workbooks(fn)
    On Error GoTo 0
    
    Application.ScreenUpdating = False
    If wbM Is Nothing Then
        If Dir(fd & "\" & fn) = fn Then
            Set wbM = Workbooks.Open(Filename:=fd & "\" & fn, ReadOnly:=True)
            opnFlg = True
        Else
            MsgBox "「" & fd & "\" & fn & "」が見つかりません!処理中止。", vbExclamation
            GoTo EXT_LABEL
        End If
    Else
        If wbM.Path <> fd Then
            MsgBox "「" & fn & "」と同名ファイルが開いています!閉じてから再実行してください。", vbExclamation
            GoTo EXT_LABEL
        End If
    End If
    Set shS = ThisWorkbook.Worksheets("Sheet1")
    Set shM = wbM.Worksheets("Sheet2")
    For irow = 8 To 39
        With shM.Range("A2:A" & shM.Cells(shM.Rows.Count, 1).End(xlUp).Row)
            Set fnd = .Find(What:=shS.Cells(irow, 1) _
                , LookIn:=xlValues _
                , LookAt:=xlWhole)
        End With
        If Not fnd Is Nothing Then
            shS.Cells(irow, "B").Value = shM.Cells(fnd.Row, "G").Value
        End If
    Next irow
    If opnFlg = True Then
        wbM.Close SaveChanges:=False
    End If
EXT_LABEL:
    Application.ScreenUpdating = True
End Sub

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

  • 取り消す
  • キャンセル

アバター

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

2019/4/23 08:07:32

お二人ともありがとうございました。
いち早くご回答頂きましたので、ベストアンサーとさせて頂きます(*´∀`*)

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

1〜1件/1件中

kik********さん

2019/4/1716:01:18

雰囲気、以下でどうなりますか

標準モジュールに以下を記述します
★ 部分デスクトップにあるファイル名に更新して、Samp1 を実行してみます

B 列が作られないようなら、
2か所ある ▼ 行をコメント、次の行を有効にして・・・どうなりますか


Option Explicit

Public Sub Samp1()
   Dim sPath As String, sFile As String
   Dim dic As Object
   Dim rng As Range
   Dim vA As Variant, v As Variant
   Dim i As Long
   Const CFILE As String = "マスターデータ.xlsx" ' ★

   With CreateObject("WScript.Shell")
      sPath = .SpecialFolders("Desktop") & "\"
   End With
   sFile = Dir(sPath & CFILE)
   If (sFile = "") Then Exit Sub

   Application.ScreenUpdating = False
   Set dic = CreateObject("Scripting.Dictionary")
   With ThisWorkbook.Worksheets("Sheet1")
      With .Range("A8:A39")
         vA = .Value
         For i = 1 To UBound(vA)
            If (vA(i, 1) <> "") Then
               dic(vA(i, 1)) = i ' ▼
'               dic(Format(vA(i, 1), "yyyymmdd")) = i
               vA(i, 1) = ""
            End If
         Next

         With Workbooks.Open(sPath & sFile, ReadOnly:=True)
            With .Worksheets("Sheet2")
               For Each rng In .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
                  v = rng.Value ' ▼
'                  v = Format(rng.Value, "yyyymmdd")
                  If (dic.Exists(v)) Then
                     vA(dic(v), 1) = rng.EntireRow.Range("G1").Value
                     dic.Remove v
                     If (dic.Count = 0) Then Exit For
                  End If
               Next
            End With
            .Close False
         End With

         .Offset(, 1).Value = vA
      End With
   End With
   Set dic = Nothing
   Application.ScreenUpdating = True
End Sub

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

  • 取り消す
  • キャンセル

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

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

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

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

閉じる

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

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

閉じる