Rất tiếc là mình không thể đọc được file; Có lẽ do máy cà tèng quá đi rồi!
Nội dung trong file đây ạ
Mong Anh ChanhTQ@ giải thích giùm em nha!
Module1:
Public Sub Lap_Nhieu_Xa()
Dim Tinh, Huyen, DSXa As Range, Ws As Worksheet, Cll As Range
CSDL = Sheet1.UsedRange
BangMa = Sheet3.UsedRange
Call LapThongSo
Call MaBieu1B
Tinh = Sheet2.Range("B2")
Huyen = Sheet2.Range("B3")
Set DSXa = Sheet2.Range("A6").CurrentRegion
Application.DisplayAlerts = False
For Each Ws In Worksheets
If Ws.Name <> "CSDL" And Ws.Name <> "TONG" And Ws.Name <> "MA1B" And Ws.Name <> "GOC1B" Then
Ws.Delete
End If
Next Ws
For Each Cll In DSXa
Sheets("GOC1B").Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Visible = True
Sheets(Sheets.Count).Name = Cll.Value
With Sheets(Cll.Value).Activate
Call Tinh_Toan_1B(Tinh, Huyen, Cll.Value)
Call DienCongThuc
Sheets(Cll.Value).Tab.ThemeColor = xlThemeColorAccent6
End With
Next Cll
Application.DisplayAlerts = True
End Sub
Private Sub LapThongSo()
Dim CayDS, Tam, r As Long, rw As Integer
CayDS = Sheet3.Range("C113", Sheet3.Range("D113").End(xlDown))
ReDim ThongSo(1 To UBound(CSDL), 1 To 7)
'1-2 NgSinh-Trong,3SanXuat-Khac, 4 Lapdia, 5 LoaiCay, 6-8 TruLuong
For r = 2 To UBound(CSDL)
Tam = IIf(CSDL(r, 29) = "MDK", 0, IIf(Left(CSDL(r, 29), 2) = "SX", 3, CSDL(r, 29)))
If Tam <> "" Then
If CSDL(r, 14) = 1 Then ThongSo(r, 1) = CSDL(r, 14) & " " & CSDL(r, 43) & " " Tam
If CSDL(r, 14) = 2 Then ThongSo(r, 2) = CSDL(r, 14) & " " & CSDL(r, 21) & " " &Tam
If CSDL(r, 17) <> "" Then
For rw = 1 To UBound(CayDS)
If InStr(CSDL(r, 17), CayDS(rw, 1)) Then
ThongSo(r, 3) = CayDS(rw, 2) & " " & Tam
End If
Next rw
If ThongSo(r, 3) = "" Then ThongSo(r, 3) = CSDL(r, 17) & " " & Tam
End If
ThongSo(r, 4) = CSDL(r, 27) & " " & Tam
ThongSo(r, 5) = IIf(Len(CSDL(r, 15)) = 2, CSDL(r, 15), Left(CSDL(r, 15), 2)) & " " & Tam
If CSDL(r, 25) < 50 Then ThongSo(r, 6) = "K" & " " & Tam
If CSDL(r, 25) >= 50 And CSDL(r, 25) <= 100 Then ThongSo(r, 6) = "N" & " " & Tam
If CSDL(r, 25) > 100 And CSDL(r, 25) <= 200 Then ThongSo(r, 6) = "TB" & " " & Tam
If CSDL(r, 25) > 200 Then ThongSo(r, 6) = "G" & " " & Tam
If CSDL(r, 26) < 50 Then ThongSo(r, 7) = "K" & " " & Tam
If CSDL(r, 26) >= 50 And CSDL(r, 26) <= 100 Then ThongSo(r, 7) = "N" & " " & Tam
If CSDL(r, 26) > 100 And CSDL(r, 26) <= 200 Then ThongSo(r, 7) = "TB" & " " & Tam
If CSDL(r, 26) > 200 Then ThongSo(r, 7) = "G" & " " & Tam
Else
If CSDL(r, 14) = 1 Then ThongSo(r, 1) = CSDL(r, 14) & " " & CSDL(r, 43)
If CSDL(r, 14) = 2 Then ThongSo(r, 2) = CSDL(r, 14) & " " & CSDL(r, 21)
If CSDL(r, 17) <> "" Then
For rw = 1 To UBound(CayDS)
If InStr(CSDL(r, 17), CayDS(rw, 1)) Then
ThongSo(r, 3) = CayDS(rw, 2)
End If
Next rw
If ThongSo(r, 3) = "" Then ThongSo(r, 3) = CSDL(r, 17)
End If
ThongSo(r, 4) = CSDL(r, 27)
ThongSo(r, 5) = IIf(Len(CSDL(r, 15)) = 2, CSDL(r, 15), Left(CSDL(r, 15), 2))
If CSDL(r, 25) < 50 Then ThongSo(r, 6) = "K"
If CSDL(r, 25) >= 50 And CSDL(r, 25) <= 100 Then ThongSo(r, 6) = "N"
If CSDL(r, 25) > 100 And CSDL(r, 25) <= 200 Then ThongSo(r, 6) = "TB"
If CSDL(r, 25) > 200 Then ThongSo(r, 6) = "G"
If CSDL(r, 26) < 50 Then ThongSo(r, 7) = "K"
If CSDL(r, 26) >= 50 And CSDL(r, 26) <= 100 Then ThongSo(r, 7) = "N"
If CSDL(r, 26) > 100 And CSDL(r, 26) <= 200 Then ThongSo(r, 7) = "TB"
If CSDL(r, 26) > 200 Then ThongSo(r, 7) = "G"
End If
Next r
End Sub
Private Sub MaBieu1B()
Dim LoaiRung, HangMuc, r As Long, c As Long
Dim Tam, Chuoi()
With Sheet5
LoaiRung = .Range("A9", .Range("A1000000").End(xlUp))
HangMuc = .Range("D8
8")
ReDim Chuoi(1 To UBound(LoaiRung), 1 To 1)
End With
For r = 1 To UBound(LoaiRung)
If IsNumeric(Left(LoaiRung(r, 1), 1)) = True Then
Tam = Tim(LoaiRung(r, 1), BangMa, 6, 4)
Chuoi(r, 1) = Tam
Else
If Left(LoaiRung(r, 1), 1) = " " Then Chuoi(r, 1) = Trim(Tam & " " & Tim(LoaiRung(r, 1), BangMa, 6, 4))
End If
Next r
For r = 1 To UBound(LoaiRung) - 1
If IsNumeric(Left(LoaiRung(r, 1), 1)) = True And Left(LoaiRung(r + 1, 1), 1) = " " Then
Chuoi(r, 1) = ""
End If
Next r
For c = 1 To UBound(HangMuc, 2)
If Tim(HangMuc(1, c), BangMa, 6, 4) <> "" Then
Tam = Tim(HangMuc(1, c), BangMa, 6, 4)
For r = 1 To UBound(Bieu1B)
If Chuoi(r, 1) <> "" Then
Bieu1B(r, c) = Chuoi(r, 1) & " " & Tam
End If
Next r
End If
Next c
End Sub
Public Sub Tinh_Toan_1B(Tinh, Huyen, Xa)
Dim TenXa, Tam, Dau, Cuoi, DonVi, BaoCao(), r As Long, c As Long, cl As Long
Range("C3") = Tinh
Range("B3") = Huyen
Range("A3") = Xa
Range("A3:C3").Font.Size = 10
Range("A3:C3").Font.Bold = 1
TenXa = Range("A3")
DonVi = Range("C9:C49")
ReDim BaoCao(1 To UBound(Bieu1B), 1 To UBound(Bieu1B, 2))
For r = 2 To UBound(CSDL)
If TenXa = CSDL(r, 6) Then
Dau = r
Exit For
End If
Next r
For r = UBound(CSDL) To Dau + 1 Step -1
If TenXa = CSDL(r, 6) Then
Cuoi = r
Exit For
End If
Next r
For r = 1 To UBound(Bieu1B)
For c = 1 To UBound(Bieu1B, 2)
If Bieu1B(r, c) <> "" Then
Tam = Dong(Bieu1B(r, c), ThongSo, Dau, Cuoi)
Tam = Split(Tam)
If IsArray(Tam) = True Then
For cl = 0 To UBound(Tam)
BaoCao(r, c) = BaoCao(r, c) + CSDL(Tam(cl), IIf(Len(DonVi(r, 1)) < 4, 25, 26))
Next cl
End If
End If
Next c
Next r
Range("D9").Resize(UBound(Bieu1B), UBound(Bieu1B, 2)).ClearContents
Range("D9").Resize(UBound(Bieu1B), UBound(Bieu1B, 2)) = BaoCao
End Sub
Private Sub DienCongThuc()
Dim DL, Dau, Cuoi, Dong, r As Long, rw As Long, c As Long
Application.ScreenUpdating = False
Dong = Range("A1000000").End(xlUp).Row
DL = Range(Cells(1, 1), Cells(Dong + 1, 16))
For r = 9 To Dong
If IsNumeric(Left(DL(r, 1), 1)) = True Then
If Left(DL(r + 1, 1), 1) = " " Then
Dau = r + 1
For rw = Dau To Dong
If Left(DL(rw, 1), 1) <> " " Then Exit For
Next rw
Cuoi = rw - Dau
For c = 5 To 16
If c <> 10 And c <> 5 Then
Cells(r, c) = "=sum(R[1]C:R[" & Cuoi & "]C)"
End If
Next c
End If
End If
For c = 5 To 16
If c <> 10 And c <> 5 Then
Cells(9, c) = "=R[1]C+R[4]C+R[8]C"
Cells(20, c) = "=R[1]C+R[2]C+R[3]C+R[7]C"
Cells(44, c) = "=R[1]C+R[2]C+R[3]C+R[4]C"
End If
Next c
If UCase(Left(Cells(r, 1), 3)) <> "III" Then
Cells(r, 4) = "=RC[1]+RC[6]+RC[11]+RC[12]"
Cells(r, 5) = "=RC[1]+RC[2]+RC[3]+RC[4]"
Cells(r, 10) = "=RC[1]+RC[2]+RC[3]+RC[4]"
End If
If Range("A" & r).Font.Bold = True Then
Range("C" & r, "P" & r).Font.Bold = True
End If
Next r
Range("D8", "P" & Dong).Style = "comma"
Range("A1", "P" & Dong).Font.Size = 9
Range("A1", "P" & Dong).Font.Name = "Times New Roman"
Range("D8", "P" & Dong).Columns.AutoFit
Range("D8").RowHeight = 0
Range("A5", "P" & Range("A1000000").End(xlUp).Row).Borders.LineStyle = 1
Application.ScreenUpdating = True
End Sub
Module2:
Public CSDL, ThongSo, BangMa, Bieu1B(1 To 40, 1 To 13), MTinh, CTinh, CHuyen, MHuyen, CXa
Public Sub CapNhat()
Call SapXepCSDL
Call Lap_DanhSach
End Sub
Private Sub Lap_DanhSach()
Dim r, Nguon
Nguon = Sheet1.UsedRange
Set DicDd1 = New Scripting.Dictionary
Set DicDd2 = New Scripting.Dictionary
For r = 2 To UBound(Nguon)
If InStr(DicDd1.Item(Nguon(r, 50)), Nguon(r, 51)) = 0 Then
DicDd1.Item(Nguon(r, 50)) = DicDd1.Item(Nguon(r, 50)) & IIf(DicDd1.Item(Nguon(r, 50)) = "", "", ",") & Nguon(r, 51)
End If
If InStr(DicDd2.Item(Nguon(r, 51)), Nguon(r, 6)) = 0 Then
DicDd2.Item(Nguon(r, 51)) = DicDd2.Item(Nguon(r, 51)) & IIf(DicDd2.Item(Nguon(r, 51)) = "", "", ",") & Nguon(r, 6)
End If
Next r
MTinh = DicDd1.keys
CTinh = Join(DicDd1.keys, ",")
CHuyen = DicDd1.items
MHuyen = DicDd2.keys
CXa = DicDd2.items
With Sheet2
.Range("B2").Interior.ColorIndex = 6
.Range("B2").Validation.Delete
.Range("B2").Validation.Add xlValidateList, , , CTinh
.Range("B2") = Split(CTinh, ",")(0)
End With
Set DicDd1 = Nothing
Set DicDd2 = Nothing
End Sub
Private Sub SapXepCSDL()
With Sheet1
.Range("A1", .Range("AY1000000").End(xlUp)).Sort key1:=.Range("F1"), Header:=xlYes
End With
End Sub
Public Function Tim(GiaTri, Mang, CotTim, Cotkq)
Dim i, j
For i = 1 To UBound(Mang)
If GiaTri = Mang(i, CotTim) Then
j = j + 1
Tim = Mang(i, Cotkq)
Exit For
End If
Next i
If j = "" Then Tim = ""
End Function
Public Function Dong(Chuoi, Mang, Dau, Cuoi)
Dim r, c
For r = Dau To Cuoi
For c = 1 To UBound(Mang, 2)
If Mang(r, c) = Chuoi Then
Dong = Dong & " " & r
End If
Next c
Next r
Dong = Trim(Dong)
End Function
Sheet2(TONG)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Tam, c
If Target.Address = "$B$2" Then
Range("B3").Validation.Delete
For c = 0 To UBound(MTinh)
If Range("B2") = MTinh(c) Then Exit For
Next c
Range("B3").Validation.Add xlValidateList, , , CHuyen(c)
Range("B3") = Split(CHuyen(c), ",")(0)
Range("B3").Interior.ColorIndex = 6
End If
If Target.Address = "$B$3" Then
For c = 0 To UBound(MHuyen)
If Range("B3") = MHuyen(c) Then Exit For
Next c
Range("B4").Validation.Delete
Range("B4").Validation.Add xlValidateList, , , CXa(c)
Range("B4") = Split(CXa(c), ",")(0)
Range("B4").Interior.ColorIndex = 6
Tam = Split(CXa(c), ",")
Range("A6", Range("A6").End(xlDown)).ClearContents
Range("A6").Resize(UBound(Tam) + 1, 1) = Application.Transpose(Tam)
End If
End Sub
