| |
こんにちは
これでどうかな？
Option Explicit
Private Sub CommandButton1_Click()
Dim FileName As String
Dim MYPATH As String
Dim WB As Workbook
Dim r1 As Long
Dim r2 As Long
Dim Da1 As Date
Dim Da2 As Date
Dim strFileName As String
With ThisWorkbook.Worksheets("保守期限一覧表")
r1 = .Range("B65536").End(xlUp).Row
If r1 < 5 Then
.Range("B5：AR" & r1).ClearContents
End If
End With
MYPATH = "\\1111\22222\出荷管理\管理表\管理表\"
strFileName = MYPATH & "管理表マスター" & ".xls"
If Dir(strFileName) <> "" Then
Set WB = Workbooks.Open(strFileName)
With WB.Worksheets("管理表マスター")
r2 = .Range("D65536").End(xlUp).Row
If IsDate(Me.TextBox1.Value) And IsDate(Me.TextBox2.Value) Then
Da1 = Format(Me.TextBox1.Value, .Range("BG6").NumberFormat)
Da2 = Format(Me.TextBox2.Value, .Range("BG6").NumberFormat)
If .AutoFilterMode = False Then
.Range("M3:BG3").AutoFilter
End If
With .Range("M3:BG" & r2)
.AutoFilter field:=47, Criteria1:=">=" & Da1, Operator:=xlAnd, _
Criteria2:="<=" & Da2
.AutoFilter field:=1, Criteria1:="=保守*"
End With
If .Range("M65536").End(xlUp).Row > 4 Then
.Range("B4:K" & r2).SpecialCells(xlCellTypeVisible).Copy 'B4〜Kまでコピーされず
ThisWorkbook.Worksheets("保守期限一覧表").Range("B5").PasteSpecial xlValues
.Range("M4:W" & r2).SpecialCells(xlCellTypeVisible).Copy 'N4からコピーされてしまいます。
ThisWorkbook.Worksheets("保守期限一覧表").Range("L5").PasteSpecial xlValues
.Range("AZ4:BU" & r2).SpecialCells(xlCellTypeVisible).Copy
ThisWorkbook.Worksheets("保守期限一覧表").Range("W5").PasteSpecial xlValues
Application.CutCopyMode = False
Else
MsgBox "抽出データはありません", vbInformation
End If
.AutoFilterMode = False
Else
MsgBox "入力された値が日付として確認できませんでした", vbInformation
End If
End With
Workbooks("管理表マスター.xls").Close savechanges:=False
Else
MsgBox strFileName & "がありません"
End If
With ThisWorkbook.Worksheets("保守期限一覧表")
.Cells.EntireColumn.AutoFit
.Range("A:A").ColumnWidth = 4
.Range("X:X").ColumnWidth = 7.5
.Range("Z:Z").ColumnWidth = 7.5
End With
Unload UserForm1
End Sub
|
|
Statis
- 06/4/28(金) 14:45 -
