Public Sub helloAtual()
Dim lr As Long, rngC As Range, lrSheet1 As Long
lr = Sheet8.UsedRange.SpecialCells(xlCellTypeLastCell).Row
With Sheet1
.[Z1].ClearContents
.[Z2].Value = "=AND(ATual!D9>0,ATual!E9=""Assy"",ATual!F9=""Stock"")"
Sheet8.Range("D8:F" & lr).AdvancedFilter xlFilterInPlace, .[Z1:Z2]
On Error Resume Next
Set rngC = Sheet8.Range("C9:C" & lr).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rngC Is Nothing Then Exit Sub
lrSheet1 = WorksheetFunction.Max(.Range("C4").CurrentRegion.SpecialCells(xlCellTypeLastCell).Row, 5)
.Range("C5:H" & lrSheet1).ClearContents
rngC.Copy
.[C5].PasteSpecial xlPasteValues
Sheet8.Range("D9:D" & lr).SpecialCells(xlCellTypeVisible).Copy
.[F5].PasteSpecial xlPasteValues
lrSheet1 = .[F4].End(xlDown).Row
.Range("D5:D" & lrSheet1).Value = 1111000570
.Range("G5:G" & lrSheet1).Value = "CBU"
.Range("E5:E" & lrSheet1).Value = Format(Date, "yyyyMMdd")
.Range("H5:H" & lrSheet1).Value = Format(Date, "yyyyMMdd")
Sheet8.Range("D8:F" & lr).AutoFilter
.[Z2].ClearContents
End With
End SubPublic Sub hello0915()
Dim lr As Long, rngC As Range, lrS2 As Long
lr = Sheet4.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Sheet4.Range("FJ7:FK" & lr).AutoFilter 2, ">0"
On Error Resume Next
Set rngC = Sheet4.Range("X8:X" & lr).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rngC Is Nothing Then Exit Sub
With Sheet2
lrS2 = WorksheetFunction.Max(.Range("C4").CurrentRegion.SpecialCells(xlCellTypeLastCell).Row, 5)
.Range("C5:H" & lrS2).ClearContents
rngC.Copy
.[C5].PasteSpecial xlPasteValues
Sheet4.Range("FK8:FK" & lr).SpecialCells(xlCellTypeVisible).Copy
.[F5].PasteSpecial xlPasteValues
lrS2 = .[F4].End(xlDown).Row
.Range("D5:D" & lrS2).Value = 1111000570
.Range("G5:G" & lrS2).Value = "CBU"
.Range("E5:E" & lrS2).Value = Format(Date, "yyyyMMdd")
.Range("H5:H" & lrS2).Value = Format(Date, "yyyyMMdd")
Sheet4.Range("FJ7:FK" & lr).AutoFilter
End With
End Sub
mong muốn 3 chép vào workSheet nha
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect([A1:A1], Target) Is Nothing Then
With UserForm1
.StartUpPosition = 0
.Top = [D18].Top - 50
.Left = [D18].Left + 20
.Show
End With
End If
End Submong muốn 2 có lẽ mình làm không đúng ý nhỉ. còn vụ lưu file bằng name tại cell B2 thì chịu. để mò tiếp
Đấy là dữ liệu mình dán để mình họa, mình lấy từ dữ liệu mình test.
Public Sub hello6()
hello67 Sheet5
End SubPublic Sub hello67(targetWS As Worksheet, Optional ByVal endDate As Variant, _
Optional ByVal startRow As Integer = 5, Optional ByVal startCol As String = "C")
Dim lr As Long, arr As Variant, r As Long, c As Long, k As Long, arrRS As Variant, today As Variant
lr = Sheet8.UsedRange.SpecialCells(xlCellTypeLastCell).Row
arr = Sheet8.Range("C8:AM" & lr).Value
today = Format(Date, "yyyyMMdd")
If IsMissing(endDate) Then endDate = Sheet8.[AM8].Value
If IsEmpty(endDate) Then endDate = -1
ReDim arrRS(1 To 500000, 1 To 6)
For r = 2 To UBound(arr) Step 1
If arr(r, 4) = "Stock" Then
If InStr(arr(r, 3), "Assy") > 0 Then
If IsNumeric(arr(r, 2)) Then
If arr(r, 2) > 0 Then
For c = 6 To UBound(arr, 2) Step 1
If arr(1, c) <= endDate Then
If IsNumeric(arr(r, c)) Then
If arr(r, c) > 0 Then
k = k + 1
arrRS(k, 1) = arr(r, 1)
arrRS(k, 2) = 1111000570
arrRS(k, 3) = arr(1, c)
arrRS(k, 4) = arr(1, c)
arrRS(k, 5) = arr(r, c)
arrRS(k, 6) = today
End If
End If
End If
Next
End If
End If
End If
End If
Next
With targetWS
lr = WorksheetFunction.Max(.Range(startCol & startRow - 1).CurrentRegion.SpecialCells(xlCellTypeLastCell).Row, startRow)
.Range(startCol & startRow & ":" & startCol & lr).Resize(, 6).ClearContents
If k > 0 Then .Range(startCol & startRow).Resize(k, 6) = arrRS
End With
End SubPrivate Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$2" Then
hello67 Sheet6, Target.Value, 7, "B"
End If
End Sub
