『VBA コピーできない』（sima）

おはおようございます。
一番下から三行目、コピーメソッドの Rangeが失敗というエラーになってしまい、苦戦しております。
どなたか分かる方いらっしゃいますでしょうか？
よろしくお願いします。


Sub Work()


'This Year

Dim dstSH As Worksheet
Dim i As Long, C As Long, srcWB As Workbook
Dim srcRNG As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False

With ActiveSheet
    Set dstSH = Workbooks.Add.Worksheets(1)

    For C = 7 To 13 Step 3
        Set srcWB = Workbooks.Open(.Cells(C, "D").Value)
        Set srcRNG = Nothing
    
        With srcWB.Worksheets(1)
            For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                If C = 10 Then
                    .Cells(i, "AH").Value = "LY"
                ElseIf C = 13 Then
                    .Cells(i, "AH").Value = "TYA"
                End If
                
                    Select Case True
                       Case .Cells(i, "AB").Value = "REVERSED"
                       Case .Cells(i, "AC").Value = "催事"
                       Case .Cells(i, "AD").Value <> ""
                       Case .Cells(i, "C").Value = "0801100" And WorksheetFunction.CountIf(.Parent.Worksheets(2).Range("A:A"), Cells(i, "B").Value) > 0
                       
                       Case Else
                           If srcRNG Is Nothing Then
                               Set srcRNG = Intersect(.Rows(i), .Range("B:C,E:E,V:V,Z:AA,AH:AH"))
                           Else
                               Set srcRNG = Union(srcRNG, Intersect(.Rows(i), .Range("B:C,E:E,V:V,Z:AA,AH:AH")))
                           End If
                    End Select
                Next i
            End With
    
            If Not srcRNG Is Nothing Then
               srcRNG.Copy dstSH.Cells(dstSH.Rows.Count, "A").End(xlUp).Offset(1)
            End If
            
            srcWB.Close False
    
    Next C
End With

If dstSH.Range("A1").Value = "" Then dstSH.Rows(1).Delete


'SS 21用に書き換え

Dim keySS1 As String, hkeySS As String
Dim pkeySS2 As Long, lpkeySS2 As Long, keySS2 As String
Dim tpkeySS2 As Long, keySS3 As String
Dim wbThis As Workbook

Set wbThis = ThisWorkbook
If wbThis.Worksheets("Macro").Range("I3").Value <> "TTL" Then

    keySS1 = wbThis.Worksheets("Macro").Range("I3").Value
    hkeySS = Left(keySS1, 2)
    pkeySS2 = Right(keySS1, 2)
    lpkeySS2 = pkeySS2 - 1
    keySS2 = hkeySS & " " & lpkeySS2
    tpkeySS2 = pkeySS2 - 2
    keySS3 = hkeySS & " " & tpkeySS2
    
    Dim ij As Long
    Dim srcRNG2 As Range
    
    With dstSH
        For ij = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            
            Select Case True
                Case .Cells(ij, "D").Value = keySS1
                    If srcRNG2 Is Nothing Then
                        Set srcRNG2 = .Rows(ij)
                    Else
                        Set srcRNG2 = Union(srcRNG2, .Rows(ij))
                    End If
                
                Case .Cells(ij, "D").Value = keySS2
                    If srcRNG2 Is Nothing Then
                        Set srcRNG2 = .Rows(ij)
                    Else
                        Set srcRNG2 = Union(srcRNG2, .Rows(ij))
                    End If
                
                Case .Cells(ij, "D").Value = keySS3
                    If srcRNG2 Is Nothing Then
                        Set srcRNG2 = .Rows(ij)
                    Else
                        Set srcRNG2 = Union(srcRNG2, .Rows(ij))
                    End If
                    
            End Select
        Next ij
    End With
    
    If Not srcRNG2 Is Nothing Then
        dstSH.Cells.Clear
        srcRNG2.Copy dstSH.Range("A1").Value
    End If
End If




＜ 使用 Excel：Office365、使用 OS：MacOSX ＞
----
 おはよ〜ございます　＾＾
Value
いらない。。。かも。。。m(__)m
（隠居じーさん） 2021/07/11(日) 08:25
----
隠居じーさんさん

おはようございます！
value 消しましたが、やはりエラーになっていまいます。。
（sima） 2021/07/11(日) 08:33
----
 w(◎ 。×）w ガ〜ン

 。。。わかりません
 すみません。
 m(_ _)m
（隠居じーさん） 2021/07/11(日) 09:33
----
その箇所のコードを、手打ちで入力ではなく、こちらにコピーペイストしてください。
また、エラーメッセージを正確に教えてください。

（γ） 2021/07/11(日) 09:39
----
エラーのアラートが出ないですかね？
で、ちゃん読んだ？
（ブヒ） 2021/07/11(日) 09:46
----
こんな感じですかね。（こんな感じだからエラーになると言う意味）

Range("2:2,4:5,7:7,11:11,15:17,19:19").Copy Sheets("Sheet2").Range("B2")
Range("2:2").Copy Sheets("Sheet2").Range("B2")


（ブヒ） 2021/07/11(日) 09:47
----
Range("2:2").Copy Sheets("Sheet2").Range("5:5")
Range("2:2").Copy Sheets("Sheet2").Range("A5").Rows
↑
めんどいので、
普通にコピーして、PasteSpecial すれば良いのに何で恰好つけたがるのか・・・。

（ブヒ） 2021/07/11(日) 10:07
----
↓の続きですよね。
[[20210626211137]]　『vba 計算高速化』（sima）
[[20210617002029]]　『VBA 日付操作』（sima）
前提となるトピックがあるなら、リンク（記事番号を二重角括弧で囲む）を置いておくとよいとおもいます。

また、コードを提示されるなら、Sub〜【End Sub】までが１つのかたまりですから、すべて提示されたほうがよいでしょう。

さらに、指摘があるあるように、エラーが発生する【箇所】のほかに、エラー番号、エラーメッセージも併せて提示されると回答者側で状況が把握しやすくなります。

（もこな２ ） 2021/07/11(日) 11:17
----
隠居じーさんさん
いえいえ、ありがとうございました！

γさん
いつもありがとうございます！
1004、オブジェクトcopyのメソッドrangeが失敗となってしまいます。
下記が問題箇所のコピーです。
よろしくお願いします。
srcRNG2.Copy dstSH.Range("A1")

ブヒさん
プログラミング自体を独学で勉強し始めて３ヶ月ほどでして、
何がカッコつけで、何がそうでないのかよくわかっていません。。
サンプルコードありがとうございました！
本日の夜、時間がありますので試してみます。

もこな２さん
失礼致しました。
いつもありがとうございます！
下記が全てのプロシージャです。




[[20210626211137]]　『vba 計算高速化』（sima） 
[[20210617002029]]　『VBA 日付操作』（sima） 



'Sub ThisYear()
'    fname = Application.GetOpenFilename
'    If fname <> False Then Range("D7") = fname
'End Sub
'
'Sub LastYear()
'    fname = Application.GetOpenFilename
'    If fname <> False Then Range("D10") = fname
'End Sub
'
'Sub TwoYearsAgo()
'    fname = Application.GetOpenFilename
'    If fname <> False Then Range("D13") = fname
'End Sub

Sub Work()


'This Year

Dim dstSH As Worksheet
Dim i As Long, C As Long, srcWB As Workbook
Dim srcRNG As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False

With ActiveSheet
    Set dstSH = Workbooks.Add.Worksheets(1)

    For C = 7 To 13 Step 3
        Set srcWB = Workbooks.Open(.Cells(C, "D").Value)
        Set srcRNG = Nothing
    
        With srcWB.Worksheets(1)
            For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                If C = 10 Then
                    .Cells(i, "AH").Value = "LY"
                ElseIf C = 13 Then
                    .Cells(i, "AH").Value = "TYA"
                End If
                
                    Select Case True
                       Case .Cells(i, "AB").Value = "REVERSED"
                       Case .Cells(i, "AC").Value = "催事"
                       Case .Cells(i, "AD").Value <> ""
                       Case .Cells(i, "C").Value = "0801100" And WorksheetFunction.CountIf(.Parent.Worksheets(2).Range("A:A"), Cells(i, "B").Value) > 0
                       
                       Case Else
                           If srcRNG Is Nothing Then
                               Set srcRNG = Intersect(.Rows(i), .Range("B:C,E:E,V:V,Z:AA,AH:AH"))
                           Else
                               Set srcRNG = Union(srcRNG, Intersect(.Rows(i), .Range("B:C,E:E,V:V,Z:AA,AH:AH")))
                           End If
                    End Select
                Next i
            End With
    
            If Not srcRNG Is Nothing Then
               srcRNG.Copy dstSH.Cells(dstSH.Rows.Count, "A").End(xlUp).Offset(1)
            End If
            
            srcWB.Close False
    
    Next C
End With

If dstSH.Range("A1").Value = "" Then dstSH.Rows(1).Delete


'SS 21用に書き換え

Dim keySS1 As String, hkeySS As String
Dim pkeySS2 As Long, lpkeySS2 As Long, keySS2 As String
Dim tpkeySS2 As Long, keySS3 As String
Dim wbThis As Workbook

Set wbThis = ThisWorkbook
If wbThis.Worksheets("Macro").Range("I3").Value <> "TTL" Then

    keySS1 = wbThis.Worksheets("Macro").Range("I3").Value
    hkeySS = Left(keySS1, 2)
    pkeySS2 = Right(keySS1, 2)
    lpkeySS2 = pkeySS2 - 1
    keySS2 = hkeySS & " " & lpkeySS2
    tpkeySS2 = pkeySS2 - 2
    keySS3 = hkeySS & " " & tpkeySS2
    
    Dim ij As Long
    Dim srcRNG2 As Range
    
    With dstSH
        For ij = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            
            Select Case True
                Case .Cells(ij, "D").Value = keySS1
                    If srcRNG2 Is Nothing Then
                        Set srcRNG2 = .Rows(ij)
                    Else
                        Set srcRNG2 = Union(srcRNG2, .Rows(ij))
                    End If
                
                Case .Cells(ij, "D").Value = keySS2
                    If srcRNG2 Is Nothing Then
                        Set srcRNG2 = .Rows(ij)
                    Else
                        Set srcRNG2 = Union(srcRNG2, .Rows(ij))
                    End If
                
                Case .Cells(ij, "D").Value = keySS3
                    If srcRNG2 Is Nothing Then
                        Set srcRNG2 = .Rows(ij)
                    Else
                        Set srcRNG2 = Union(srcRNG2, .Rows(ij))
                    End If
                    
            End Select
        Next ij
    End With
    
    If Not srcRNG2 Is Nothing Then
        dstSH.Cells.Clear
        srcRNG2.Copy dstSH.Range("A1")
    End If

End If


'Week Number
Dim i2 As Long
Dim TargetD As Date
Dim ChdateL As Date, TargetLD As Date
Dim TargetTD As Date, ChdateTy As Date


Dim arrDATE As Variant
Dim arrYEAR As Variant
Dim M As Long

With dstSH
M = .Cells(Rows.Count, 1).End(xlUp).Row
ReDim arrDATE(M - 1, 0)
ReDim arrYEAR(M - 1, 0)


    .Range("C:C").Replace "-", "/"
        For i2 = 1 To M
           If .Cells(i2, "G") = "" Then
               TargetD = .Cells(i2, "C")
               arrDATE(i2 - 1, 0) = DatePart("ww", TargetD, vbMonday) _
               - DatePart("ww", DateSerial(Year(TargetD), Month(TargetD), 1), vbMonday) + 1
                arrYEAR(i2 - 1, 0) = Year(.Cells(i2, "C"))
            ElseIf .Cells(i2, "G") = "LY" Then
               TargetLD = .Cells(i2, "C")
               ChdateL = DateAdd("yyyy", 1, TargetLD)
                 arrDATE(i2 - 1, 0) = DatePart("ww", ChdateL, vbMonday) _
               - DatePart("ww", DateSerial(Year(ChdateL), Month(ChdateL), 1), vbMonday) + 1
                 arrYEAR(i2 - 1, 0) = Year(.Cells(i2, "C"))
            ElseIf .Cells(i2, "G") = "TYA" Then
               TargetTD = .Cells(i2, "C")
               ChdateTy = DateAdd("yyyy", 2, TargetTD)
                arrDATE(i2 - 1, 0) = DatePart("ww", ChdateTy, vbMonday) _
               - DatePart("ww", DateSerial(Year(ChdateTy), Month(ChdateTy), 1), vbMonday) + 1
                 arrYEAR(i2 - 1, 0) = Year(.Cells(i2, "C"))
           End If
        Next i2
        
        .Range(.Cells(1, "H"), .Cells(M, "H")) = arrDATE
        .Range(.Cells(1, "I"), .Cells(M, "I")) = arrYEAR
End With



''============================================
'Transaction

Dim v As Variant
With dstSH
v = Range("A1").CurrentRegion.Resize(, 8).Value
.Range("I1").Resize(UBound(v, 1)).Formula = "=IF(COUNTIFS($A$1:A1,A1,$B$1:B1,B1,$H$1:H1,H1,$I$1:I1,I1)=1,IF(SUMIFS(D:D,A:A,A1,B:B,B1,H:H,H1,I:I,I1)<>0,1,""""),"""")"
End With

'''   '=============================================================
'
'    'Creating Sheets

Dim sc As Long, sh As Long, ws As Worksheet, MaxShop As Long, sw As Long, si As Long, Ecp As Long, Ec As Long
Dim wbThis2 As Workbook

Set wbThis2 = ThisWorkbook
sc = wbThis2.Sheets("Macro").Cells(3, "G")

For sh = 1 To sc
    wbThis.Sheets("Template").Copy after:=wbThis.Sheets("Template")
    ActiveSheet.Name = sh
    Set ws = ActiveSheet

    MaxShop = wbThis.Sheets("ShopList").Cells(Rows.Count, 1).End(xlUp).Row
        si = 4
        For sw = 2 To MaxShop
            If wbThis.Sheets("ShopList").Cells(sw, "C") = "Active" Then
                ws.Cells(si, "A") = wbThis.Sheets("ShopList").Cells(sw, "A")
                ws.Cells(si, "B") = wbThis.Sheets("ShopList").Cells(sw, "B")
                si = si + 1
            End If
        Next sw


'    'E-Commerce
Dim MaxRow As Long, EcMax As Long
MaxRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
EcMax = MaxRow + 1
 With ws
    .Cells(EcMax, "A") = wbThis.Sheets("ShopList").Cells(2, "E")
    .Cells(EcMax, "B") = wbThis.Sheets("ShopList").Cells(2, "F")
End With


'==================================================================
'TTL

'Calculation
Dim ix As Long, sx As Long, ix2 As Long, sx2 As Long
Dim Criteria1 As String, Criteria2 As String, Criteria3 As Long
Dim Criteria1a As String, Criteria2a As String, Criteria3a As Long
Dim Arr() As Variant, Arram() As Variant


ReDim Arr(EcMax - 4, 2)
ReDim Arram(EcMax - 4, 2)

If wbThis.Worksheets("Macro").Range("I3") = "TTL" Then

 'Qt
For sx = 3 To 5
    For ix = 4 To EcMax

        Criteria1 = CStr(ws.Name)
        Criteria2 = CStr(ws.Cells(ix, 1))
        Criteria3 = CLng(ws.Cells(3, sx))

        With dstSH
            Arr(ix - 4, sx - 3) = _
            WorksheetFunction.SumIfs(.Range("F:F"), _
            .Range("H:H"), Criteria1, _
            .Range("B:B"), Criteria2, _
            .Range("I:I"), Criteria3)
        End With

    Next ix
Next sx

'Amount
For sx2 = 3 To 5
    For ix2 = 4 To EcMax

        Criteria1a = CStr(ws.Name)
        Criteria2a = CStr(ws.Cells(ix2, 1))
        Criteria3a = CLng(ws.Cells(3, sx2))

        With dstSH
            Arram(ix2 - 4, sx2 - 3) = _
            Round(WorksheetFunction.SumIfs(.Range("E:E"), _
            .Range("H:H"), Criteria1a, _
            .Range("B:B"), Criteria2a, _
            .Range("I:I"), Criteria3a) / 1000, 0)
        End With

    Next ix2
Next sx2

'Transaction
Dim criTra1 As String, criTra2 As String, criTra3 As Long
Dim sx3 As Long, ix3 As Long
Dim arrTra() As Variant
ReDim arrTra(EcMax - 4, 2)


For sx3 = 3 To 5
    For ix3 = 4 To EcMax

        criTra1 = CStr(ws.Name)
        criTra2 = CStr(ws.Cells(ix3, 1))
        criTra3 = CLng(ws.Cells(3, sx3))

        With dstSH
            arrTra(ix3 - 4, sx3 - 3) = _
            WorksheetFunction.SumIfs(.Range("J:J"), _
            .Range("H:H"), criTra1, _
            .Range("B:B"), criTra2, _
            .Range("I:I"), criTra3)
        End With

    Next ix3
Next sx3


With ws
    .Range(.Cells(4, "C"), .Cells(EcMax, "E")) = Arr
    .Range(.Cells(4, "H"), .Cells(EcMax, "J")) = Arram
    .Range(.Cells(4, "M"), .Cells(EcMax, "O")) = arrTra
End With


' 個数合計
Dim ss As Long, zx As Long
Dim qtT As Long
Dim sheetNO As Long, sheetNA As String
With ws
    If ws.Name <> 1 Then
        qtT = 0
        qtT = 43
        ss = 0
        zx = 0
        sheetNO = 0
        sheetNO = CLng(ws.Name)
        sheetNA = CStr(sheetNO - 1)
        
        For ss = 3 To 5
            For zx = 4 To EcMax
                .Cells(zx, qtT) = .Cells(zx, ss) + wbThis.Worksheets(sheetNA).Cells(zx, qtT)
            Next
            qtT = qtT + 1
        Next
    End If
End With

' 売上合計
Dim sheetN2 As String, ss2 As Long, zx2 As Long
Dim atT As Long
Dim sheetNO2 As Long, sheetNA2 As String
With ws
    If ws.Name <> 1 Then
        atT = 0
        atT = 48
        ss2 = 0
        zx2 = 0
        sheetNO2 = 0
        sheetNO2 = CLng(ws.Name)
        sheetNA2 = CStr(sheetNO2 - 1)
        
        For ss2 = 8 To 10
            For zx2 = 4 To EcMax
                .Cells(zx2, atT) = .Cells(zx2, ss2) + wbThis.Worksheets(sheetNA2).Cells(zx2, atT)
            Next
            atT = atT + 1
        Next
    End If
End With

' Tra合計
Dim sheetN3 As String, ss3 As Long, zx3 As Long
Dim trT As Long
Dim sheetNO3 As Long, sheetNA3 As String
With ws
    If ws.Name <> 1 Then
        trT = 0
        trT = 53
        ss3 = 0
        zx3 = 0
        sheetNO3 = 0
        sheetNO3 = CLng(ws.Name)
        sheetNA3 = CStr(sheetNO3 - 1)
        
        For ss3 = 13 To 15
            For zx3 = 4 To EcMax
                .Cells(zx3, trT) = .Cells(zx3, ss3) + wbThis.Worksheets(sheetNA3).Cells(zx3, trT)
            Next
            trT = trT + 1
        Next
    End If
End With

End If






Dim ss4 As Long, ss5 As Long, ss6 As Long, ss7 As Long, ss8 As Long, ss9 As Long
Dim KeyW As String, KeyPR As Long, KeyR As Long
With ws
    KeyW = .Cells(21, "A")
    KeyPR = WorksheetFunction.Match(KeyW, .Range("A:A"), 0)
    KeyR = KeyPR - 1
    
    For ss4 = 3 To 5
        .Cells(21, ss4) = WorksheetFunction.Sum(Range(.Cells(4, ss4), .Cells(KeyR, ss4)))
    Next
    For ss5 = 8 To 10
        .Cells(21, ss5) = WorksheetFunction.Sum(Range(.Cells(4, ss5), .Cells(KeyR, ss5)))
    Next
    For ss6 = 13 To 15
        .Cells(21, ss6) = WorksheetFunction.Sum(Range(.Cells(4, ss6), .Cells(KeyR, ss6)))
    Next
    For ss7 = 43 To 45
        .Cells(21, ss7) = WorksheetFunction.Sum(Range(.Cells(4, ss7), .Cells(KeyR, ss7)))
    Next
    For ss8 = 48 To 50
        .Cells(21, ss8) = WorksheetFunction.Sum(Range(.Cells(4, ss8), .Cells(KeyR, ss8)))
    Next
    For ss9 = 53 To 55
        .Cells(21, ss9) = WorksheetFunction.Sum(Range(.Cells(4, ss9), .Cells(KeyR, ss9)))
    Next
End With

 '空白行を非表示
Dim rw As Long
With ws
    For rw = 4 To KeyR
        If .Range("A" & rw) = "" Then
        .Rows(rw).EntireRow.Hidden = True
        End If
    Next
End With
Next sh


Dim A() As String, ip As Long
ReDim A(Sheets.Count - 4)
For ip = 4 To Sheets.Count
    A(ip - 4) = Sheets(ip).Name
Next ip

Sheets(A).Select
Sheets(A).Move
ActiveWorkbook.SaveAs _
FileName:="/Users/yusukekobayashi/Desktop/VBA_KPI_MC_renewed/KPI.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
 

dstSH.Parent.Close savechanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub


（sima） 2021/07/11(日) 12:23
----
Range("2:2,4:5,7:7,11:11,15:17,19:19").Copy Sheets("Sheet2").Range("B2").EntireRow

提示されたコード読んでないので結果は不明。
こんな感じ？
（ブヒ） 2021/07/11(日) 12:33
----
 コードに問題があるようには思えなかったですね。
 データ側の問題でしょうか。
 ダメもとで、
    Debug.Print srcRNG2.Address
    srcRNG2.Copy dstSH.Range("A1")
 と一行追加したら、なにが出力されますか？
（γ） 2021/07/11(日) 12:54
----
ちょっと読み込んでいる間に話が進んでいるようですが、最初に提示のあったコードを整理するとこんな感じですよね。（たぶん）
    Sub メインルーチン()
        Dim dstSH As Worksheet
        Set dstSH = Workbooks.Add.Worksheets(1)
         
        Call さぶるーちん1(dstSH)
        Call さぶるーちん2(dstSH)
    End Sub
    '-------------------------------------------------------------------------------------
    Sub さぶるーちん1(ByVal dstSH As Worksheet)
        Dim MySH As Worksheet
        Dim 最終行 As Long
        Dim i As Long, C As Long, srcWB As Workbook
        Dim srcRNG As Range
    
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        
        Set MySH = ThisWorkbook.Worksheets(1) '★適宜「ActiveSheet」に依存しないものに変えてください
        
        For C = 7 To 13 Step 3
            Set srcWB = Workbooks.Open(MySH.Cells(C, "D").Value)
            Set srcRNG = Nothing
            
            With srcWB.Worksheets(1)
                最終行 = .Cells(.Rows.Count, 1).End(xlUp).Row
                
                '「srcWB.Close False」なら↓は意味ない(書き出した後に操作すればよい）のでは？-------
                If 最終行 > 1 Then
                    Select Case C
                        Case 10: .Range("AH2:AH" & 最終行).Cells(i, "AH").Value = "LY"
                        Case 13: .Range("AH2:AH" & 最終行).Cells(i, "AH").Value = "TYA"
                    End Select
                End If
                '----------------------------------------------------------------------------------------------
                For i = 2 To 最終行
                    Select Case True
                        Case .Cells(i, "AB").Value = "REVERSED"
                        Case .Cells(i, "AC").Value = "催事"
                        Case .Cells(i, "AD").Value <> ""
                        Case .Cells(i, "C").Value = "0801100" And WorksheetFunction.CountIf(.Parent.Worksheets(2).Range("A:A"), Cells(i, "B").Value) > 0
                        Case Else
                            If srcRNG Is Nothing Then
                                Set srcRNG = .Cells(i, 1)
                            Else
                                Set srcRNG = Union(srcRNG, .Cells(i, 1))
                            End If
                    End Select
                Next i
                
                If Not srcRNG Is Nothing Then
                    Intersect(srcRNG.EntireRow, .Range("B:C,E:E,V:V,Z:AA,AH:AH")).Copy dstSH.Cells(dstSH.Rows.Count, "A").End(xlUp).Offset(1)
                End If
            End With
            srcWB.Close False
        Next C
    End Sub
    '--------------------------------------------------------------------------------------
    Sub さぶるーちん2(ByVal dstSH As Worksheet)
        Dim MySTR As String
        Dim ij As Long
        Dim srcRNG2 As Range
        
        If dstSH.Range("A1").Value = "" Then dstSH.Rows(1).Delete
        MySTR = ThisWorkbook.Worksheets("Macro").Range("I3").Value
        
        For ij = 2 To dstSH.Cells(dstSH.Rows.Count, 1).End(xlUp).Row
            Select Case dstSH.Cells(ij, "D").Value
                Case MySTR, Left(MySTR, 2) & " " & Right(MySTR, 2) - 1, Left(MySTR, 2) & " " & Right(MySTR, 2) - 2
                    If srcRNG2 Is Nothing Then
                        Set srcRNG2 = dstSH.Rows(ij)
                    Else
                        Set srcRNG2 = Union(srcRNG2, dstSH.Rows(ij))
                    End If
            End Select
        Next ij

        If Not srcRNG2 Is Nothing Then
            dstSH.Cells.Clear
            srcRNG2.Copy dstSH.Range("A1") '隠居じーさんさん指摘箇所
        End If

    End Sub

コードを見る限り（データレイアウトが分からないので実際に試していないですが）隠居じーさんさんの指摘どおりでよさそうですが・・・

その時の「srcRNG2」「dstSH」に何が入っているのかチェックすると解決につながるかもですね。

ちなみに、↓は正しいの（思った通りの動作なの）ですか？
  dstSH.Cells.Clear

コピーする前に元データクリアしちゃってよいのでしょうか・・・

（もこな２ ） 2021/07/11(日) 12:56
----
みなさま
ありがとうございます。
まずはアドバイス通り、デバッグしてみました。
srcRNG2にはしっかりと数値が入っていました。
dstSHもデバッグしたのですが、イミディエイトに何も表示されません。
デバッグの仕方が間違っているのでしょうか。


If Not srcRNG2 Is Nothing Then
        Debug.Print dstSH
        Set dstSH = Nothing
        Set dstSH = Workbooks.Add.Worksheets(1)
        Debug.Print srcRNG2.Address
        srcRNG2.Copy dstSH.Range("A1")
 End If

dstSHが怪しかったので、↓こんな感じでdstSHを一度空にして、再びシートを代入しましたら無事コピーできるようになりました。
が、下に続く計算にうまくつながりません。
全体的にごちゃごちゃしてきてしまったのが原因かもしれません。
もこな２さんのcall ステートメントを取り入れて、整理しようかと思っています。


Set dstSH = Nothing
Set dstSH = Workbooks.Add.Worksheets(1)


＠もこな２さん
いつもサンプルありがとうございます。
本当に勉強になります。

＞コピーする前に元データクリアしちゃってよいのでしょうか

If wbThis.Worksheets("Macro").Range("I3").Value <> "TTL" Then 

上の条件の時だけ、dstSHを書き換える意図でした。
この条件の時だけ、さぶるーちん2(dstSH)を呼び出して、さぶるーちん1(dstSH)で作ったdstSHを書き換え、下の計算につなげたいのですが、
どこにif文を組み込めばいいのかわからず。。

お時間がある時で構いませんので教えていただきたいです。
よろしくお願いします　m(__)m




（sima） 2021/07/11(日) 23:40
----
 ちょっとこだわって済みません。
 
 | srcRNG2にはしっかりと数値が入っていました。
 | dstSHもデバッグしたのですが、イミディエイトに何も表示されません。
 ちょっと理解できませんでした。

 コードを拝見すると、 
 Set srcRNG2 = Union(srcRNG2, dstSH.Rows(ij))
 のように、
 srcRNG2は dstSHシートのいくつかの行の連結ですよね。
 
 |    If Not srcRNG2 Is Nothing Then
 |         dstSH.Cells.Clear
 |         srcRNG2.Copy dstSH.Range("A1")
 |     End If
 としたのですから、
 Copyの直前で、dstSH.Cells.Clearしているので、
 | srcRNG2にはしっかりと数値が入っていました。
 ということはありえません。
 クリアーされていないとおかしい。
 
 問題になるとすれば、同一シート内のコピーなので、
 コピー元の範囲とコピー先の範囲との関係で、
 コピーができない事態ですね。
 （例えば、1行目と3行目を同時に選択して、[A1]に貼り付ける等。
 手作業でもエラーになります。）
 この場合はもっと詳細なエラーメッセージが出ている筈なんです。
 
 Debug.Print srcRNG2.Address
 の結果を求めていましたが、きちんと回答してもらえませんか。
 今の状態だとコピーがエラーになった原因は全く不明なままです。
 少なくとも私には。
 あなたは納得なんですか？

（γ） 2021/07/12(月) 08:20