Rất cám ơn yêu cầu của bạn, nhờ vậy mình mới tầm sư học đạo và nhờ HD của NDU nên tôi viết thử code sau.
Option Explicit
Dim MyTmp02 As String, MyAdd02 As String, MyTmp03 As String, MyAdd03 As String
Dim endR As Long, r As Long
Dim ArrMaHH(), ArrCK02(), ArrCK03()
Dim rngDM As Range, rngCK02 As Range, rngCK03 As Range
Sub CapNhatDmHH()
With Application
.Calculation = xlCalculationManual: .ScreenUpdating = False
End With
'xoa DMHH'
With Sheets("DMHH").Range("A4")
endR = .Cells(1000, 2).End(xlUp).Row 'Lay theo cot tenHH'
.Resize(endR, 4).ClearContents 'Xoa DM'
.Offset(, 7).Resize(endR, 1).ClearContents 'Xoa CK2'
.Offset(, 9).Resize(endR, 1).ClearContents 'Xoa CK3'
End With
With Sheets("BGia")
endR = .Cells(1000, 2).End(xlUp).Row 'Lay theo cot tenHH'
ArrMaHH = .Range("A8:D" & endR).Value
Set rngCK02 = .Range("E8:E" & endR) 'vung co gia 2'
Set rngCK03 = .Range("G8:G" & endR) 'vung co gia 3'
End With
endR = endR - 8 + 1
ReDim ArrCK02(1 To endR, 1 To 1), ArrCK03(1 To endR, 1 To 1)
MyAdd02 = "": MyAdd03 = ""
For r = 1 To endR
'Phan CK2'
If rngCK02(r, 1).MergeCells Then
MyTmp02 = rngCK02(r, 1).MergeArea.Address
If InStr(MyAdd02, MyTmp02) = False Then
MyAdd02 = MyAdd02 & MyTmp02
ArrCK02(r, 1) = rngCK02(r, 1).Value
Else
ArrCK02(r, 1) = ArrCK02(r - 1, 1)
End If
Else
ArrCK02(r, 1) = rngCK02(r, 1).Value
End If
'Phan CK3'
If rngCK03(r, 1).MergeCells Then
MyTmp03 = rngCK03(r, 1).MergeArea.Address
If InStr(MyAdd03, MyTmp03) = False Then
MyAdd03 = MyAdd03 & MyTmp03
ArrCK03(r, 1) = rngCK03(r, 1).Value
Else
ArrCK03(r, 1) = ArrCK03(r - 1, 1)
End If
Else
ArrCK03(r, 1) = rngCK03(r, 1).Value
End If
Next r
With Sheets("BGIA")
.[J8].Resize(r - 1, 1) = ArrCK02
.[K8].Resize(r - 1, 1) = ArrCK03
End With
'Gan lai vao DMHH'
With Sheets("DMHH").Range("A4")
.Resize(endR, 4) = ArrMaHH 'Gan tenHH, Mhh..'
.Offset(, 7).Resize(endR, 1) = ArrCK02 'gan vao CK2'
.Offset(, 9).Resize(endR, 1) = ArrCK03 'gan vao CK3'
End With
Set rngDM = Nothing: Set rngCK02 = Nothing: Set rngCK03 = Nothing
Erase ArrMaHH(), ArrCK02(), ArrCK03()
With Application
.Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End SubWith Sheets("BGIA")
.[J8].Resize(r - 1, 1) = ArrCK02
.[K8].Resize(r - 1, 1) = ArrCK03
End WithSorry, bạn bỏ đi, do lúc làm để test nên quên bỏ.
Private Sub CommandButton2_Click() 'Tao Moi'
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Dim endR As Long, soHD As String
With Sheets("CTBan")
endR = .Cells(65000, 1).End(xlUp).Row
End With
If endR = 1 Then
TaoPBH
Else
LuuPBH
TaoPBH
End If
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End SubSub TaoSoPBH()
Set Sh = Sheets("CTBan")
With Sh
endR = .[B65500].End(xlUp).Row
Select Case endR
Case 1
soHD = "PX" & Right(Year(Date), 2) & Right("00" & Month(Date), 2) & "/" & "001"
Case Is > 1
soHD = .Cells(endR, 2).Value
If CLng(Mid(soHD, 3, 2)) = CLng(Right(Year(Date), 2)) Then
If CLng(Mid(soHD, 5, 2)) = CLng(Month(Date)) Then
soHD = "PX" & Right(Year(Date), 2) & Right("00" & Month(Date), 2) & "/" & Right("00" & Right(soHD, 3) + 1, 3)
Else
soHD = "PX" & Right(Year(Date), 2) & Right("00" & Month(Date), 2) & "/" & "001"
End If
End If
End Select
End With
Set Rng = Nothing: Set Sh = Nothing
End SubBạn check lại nhé, nếu có HD rồi thì chọn cancel, nó sẽ không lưu và tạo HD mới.
Có thêm bớt vài option nên code có dư vài chỗ, lúc nào rút gọn sau.
Quên mất TH2 này, cũng dễ thôi, mai làm, hình như TH1 làm rồi mà.
Bạn kiểm tra nhé. Cám ơn!
Nói chung là các code trong file trên gần như đầy đủ, cơ bản là bố trí và logich thế nào cho OK.
Private Sub KhachHang_Change()
Dim lstRes1
On Error Resume Next
Set Func = Application.WorksheetFunction
With Sheet4.Range(Sheet4.[C2], Sheet4.[C65536].End(xlUp))
Arr1 = Func.Transpose(.Cells)
End With
lstRes1 = Filter(Arr1, Me.KhachHang, True, vbTextCompare)
Me.KHList.List() = lstRes1
End Sub
