(1) Folder được chỉ định đường dẫn hay theo lựa chọn của người dùng?
Sub Main()
Dim nFoLder As String, d As Variant, tmp As Variant, z As Long, dd As Variant, r As Long, m As Long
nFoLder = GetFolder("")
If nFoLder = "" Then Exit Sub
Sheet1.Range("A3") = Right(Mid(nFoLder, InStrRev(nFoLder, "\") + 1), 7)
d = Sheet1.Range("A3")
If TypeName(d) = "Date" Then
m = WorksheetFunction.EoMonth(d, 0)
d = CLng(d)
With Sheet1
z = .Range("E" & .Rows.Count).End(xlUp).Row
If z < 5 Then Exit Sub
tmp = .Range("E5:E" & z).Value2
For r = 1 To UBound(tmp, 1)
dd = tmp(r, 1)
If IsNumeric(dd) Then
dd = CLng(dd)
If dd >= d And dd <= m Then
.Rows(r + 4).ClearContents
End If
End If
Next r
End With
End If
End Sub
'-------------------------------------------------
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End FunctionFunction GetFolder()
'Và
nFoLder = GetFolder("")
If nFoLder = "" Then Exit Sub
Sheet1.Range("A3") = Right(Mid(nFoLder, InStrRev(nFoLder, "\") + 1), 7)
Xin chào befaint
Cảm ơn bạn đã thông tin lại ạ.
Mới đầu Oanh Thơ cũng có ý định nhập luôn vào ô A3 rồi a, nhưng nghĩ có thể dùng code để tránh trường hợp nhầm lẫn hoặc quên lên nhân tiện hỏi luôn mục này bạn ạ.
Sub Main()
Dim nFoLder As String, d As Variant, tmp As Variant, z As Long, dd As Variant, r As Long, m As Long
nFoLder = ThisWorkbook.Path
Sheet1.Range("A3") = Right(Mid(nFoLder, InStrRev(nFoLder, "\") + 1), 7)
d = Sheet1.Range("A3")
If TypeName(d) = "Date" Then
m = WorksheetFunction.EoMonth(d, 0)
d = CLng(d)
With Sheet1
z = .Range("E" & .Rows.Count).End(xlUp).Row
If z < 5 Then Exit Sub
tmp = .Range("E5:E" & z).Value2
For r = 1 To UBound(tmp, 1)
dd = tmp(r, 1)
If IsNumeric(dd) Then
dd = CLng(dd)
If dd >= d And dd <= m Then
.Rows(r + 4).ClearContents
End If
End If
Next r
End With
End If
End SubSub Main()
Application.ScreenUpdating = False
Dim nFoLder As String, d As Variant, tmp As Variant, z As Long, dd As Variant, r As Long, m As Long
nFoLder = ThisWorkbook.Path
Sheet1.Range("A3") = Right(Mid(nFoLder, InStrRev(nFoLder, "\") + 1), 7)
d = Sheet1.Range("A3")
If TypeName(d) = "Date" Then
m = WorksheetFunction.EoMonth(d, -6) 'Mốc thời gian thứ nhất = m
d = CLng(d) 'Mốc thời gian thức hai = d
With Sheet1
z = .Range("E" & .Rows.Count).End(xlUp).Row
If z < 5 Then Exit Sub
tmp = .Range("E5:E" & z).Value2
For r = 1 To UBound(tmp, 1)
dd = tmp(r, 1)
If IsNumeric(dd) Then
dd = CLng(dd) 'Thời gian cần đối chiếu = dd
If dd > m And dd < d Then 'Nếu dd nằm trong khoảng thời gian từ min(m,d)=m tới max(m,d)=d thì:
.Rows(r + 4).ClearContents
End If
End If
Next r
End With
End If
Application.ScreenUpdating = True
End SubSub Main()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim d As Variant, tmp As Variant, z As Long, dd As Variant, r As Long
d = Sheet2.Range("D2")
If TypeName(d) = "Date" Then
d = CLng(d)
With Sheet1
z = .Range("M" & .Rows.Count).End(xlUp).Row
If z < 5 Then Exit Sub
tmp = .Range("M5:M" & z).Value2: z = UBound(tmp, 1)
For r = z To 1 Step -1
dd = tmp(r, 1)
If IsNumeric(dd) Then
dd = CLng(dd)
If dd < d Then
.Rows(r + 4).Delete
End If
End If
Next r
End With
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End SubSub Mainn()
Application.ScreenUpdating = False
Dim d As Variant, tmp As Variant, z As Long, dd As Variant, r As Long
Dim KQ() As Variant, c As Long, k As Long, j As Long
d = Sheet2.Range("D2")
If TypeName(d) = "Date" Then
d = CLng(d)
With Sheet1
z = .Range("M" & .Rows.Count).End(xlUp).Row
If z < 5 Then Exit Sub
tmp = .Range("B5:BI" & z).Value2: z = UBound(tmp, 1): c = UBound(tmp, 2)
ReDim KQ(1 To z, 1 To c)
For r = 1 To z
dd = tmp(r, 12)
If IsNumeric(dd) Then
dd = CLng(dd)
If dd >= d Then
j = j + 1
For k = 1 To c
KQ(j, k) = tmp(r, k)
Next k
End If
End If
Next r
If j Then
.Range("B5").Resize(z, c).ClearContents
.Range("B5").Resize(j, c) = KQ
End If
End With
End If
Application.ScreenUpdating = True
End Sub
Sub DeleteRows()
Dim DK, tmp, Drng As Range, Rng As Range, i As Long
DK = Sheet2.Range("D2").Value
If Not TypeName(DK) = "Date" Then Exit Sub
DK = CLng(DK)
i = Sheet1.Range("M" & Sheet1.Rows.Count).End(xlUp).Row
If i < 5 Then Exit Sub
Set Drng = Sheet1.Range("M5:M" & i)
For i = 1 To Drng.Rows.Count
tmp = Drng(i, 1).Value
If TypeName(tmp) = "Date" Then
If CLng(tmp) < DK Then
If Rng Is Nothing Then
Set Rng = Drng(i, 1)
Else
Set Rng = Union(Rng, Drng(i, 1))
End If
End If
End If
Next i
If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub
