| |
やはりエラーが出るのですか・・おかしいですね。
ならば分割されているコピー元を、Area毎ループで転記していくというコード
なら、大丈夫だと思います。こんな感じになります。
Dim strDate As String
Dim Sh As Worksheet
Dim MyR As Range
Dim i As Long
strDate = TextBox1.Text
Set Sh = Worksheets("結果")
With Worksheets("元データ")
Sh.Rows(1).Value = .Rows(2).Value
With .Range("C3", .Range("C65536").End(xlUp)).Offset(, 253)
.Formula = _
"=IF($C3=DATEVALUE(" & """" & strDate & """" & "),1)"
If WorksheetFunction.Count(.Cells) > 0 Then
Set MyR = Intersect(.SpecialCells(3, 1).EntireRow, _
.Parent.Range("A2").CurrentRegion)
For i = 1 To MyR.Areas.Count
With MyR.Areas(i)
Sh.Range("A65536").End(xlUp).Offset(1) _
.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
Next i
Application.Goto Sh.Range("A1"), True: Set MyR = Nothing
Else
MsgBox "該当する日付が見つかりません", 48
End If
.ClearContents
End With
End With
Set Sh = Nothing
|
|
Kein
- 06/12/1(金) 23:19 -
