Cảm ơn HieuCD
Sub Button1_Click()
Dim id1, id2, id3, id4, id5, id6 As Variant
Dim i, n As Integer
Worksheets("ACC").Activate
id1 = Sheets("ACC").Range("E5").Value
id2 = Sheets("ACC").Range("G5").Value
id3 = Sheets("ACC").Range("I5").Value
id4 = Sheets("ACC").Range("K5").Value
id5 = Sheets("ACC").Range("M5").Value
id6 = Sheets("ACC").Range("O5").Value
Worksheets("TOEICScore").Activate
Do While id1 = Sheets("TOEICScore").Range("A", i).Value Or Sheets("TOEICScore").Range("A", i).Value = Null
If id1 = Sheets("TOEICScore").Range("A", i).Value Then
Sheets("ACC").Range("F5").Value = Sheets("TOEICScore").Range("B", i).Value
Sheets("ACC").Range("E21").Value = Sheets("TOEICScore").Range("F", i).Value
Sheets("ACC").Range("F21").Value = Sheets("TOEICScore").Range("E", i).Value
End If
i = i + 1
Loop
End Subthì bỏ Option Explicit đi, nếu không chịu bỏ thì phải khai báo (dim) tất cả các biến
Cảm ơn HieuCD. Mình đã làm được rồi
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cll As Range
For Each Cll In Intersect(Target.EntireRow, [B:B])
If Cll.Row > 7 Then
If Cll.Value = "" Then
Range("A8:A1000").ClearContents
Else
If Range("A" & Cll.Row).Formula = "" Then Range("A" & Cll.Row).FormulaR1C1 = "=IF(RC[1]<>"""",MAX(R7C1:R[-1]C)+1,"""")"
If Range("L" & Cll.Row).Formula = "" Then Range("L" & Cll.Row).FormulaR1C1 = "=IF(RC[-10]="""","""",IF(RC[-5]=""x"",""x"",""/""))"
If Range("M" & Cll.Row).Formula = "" Then Range("M" & Cll.Row).FormulaR1C1 = "=IF(RC[-11]="""","""",IF(RC[-2]=R1C11,""Cdi"",IF(RC[-2]=R2C11,""Cde"",""/"")))"
If Range("N" & Cll.Row).Formula = "" Then Range("N" & Cll.Row).FormulaR1C1 = "=RIGHT(RC[-6],2)"
End If
End If
Next
End SubCảm ơn HieuCD đã nhiệt tình giúp đỡ.
Với đoạn code trên khi thực hiện với dữ liệu khoảng 3000 dòng. code chạy rất lâu.
Cảm ơn Thầy.
Cột B không biết! Cột V (Nam) là thừa (Tốn công thức) trong khi cột U ghi "x" là Nữ, để trống đã biết là Nam.
Public Sub GPE()
Dim sArr(), dArr(), I As Long, R As Long, Txt As String
Txt = "'11-14"
sArr = Range("M3", Range("M3").End(xlDown)).Resize(, 35).Value
R = UBound(sArr): ReDim dArr(1 To R, 1 To 3)
For I = 1 To R
If sArr(I, 24) <> Empty Then
If sArr(I, 24) = "HTCHTH" Then
dArr(I, 1) = "HT" & sArr(I, 25)
ElseIf sArr(I, 27) <> Empty Or sArr(I, 28) <> Empty Then
dArr(I, 1) = "CDi-BHo"
Else
dArr(I, 1) = Left(sArr(I, 24), 1)
End If
End If
dArr(I, 2) = Txt '<--------------Cột B?'
dArr(I, 3) = IIf(sArr(I, 31) <> Empty, sArr(I, 31), "/")
Next I
Range("A3").Resize(R, 3) = dArr
End SubDo vội quá nên nhầm mong thầy thông cảm.
Dạ đúng rồi ạ, e cảm ơn bác nhiều, nhưng e xin phép được nhờ thêm tí nữa ạ!
Dim shBQMau As Worksheet
Dim shBQKMau As Worksheet
Dim j As Long
Dim i As Long
Dim LastRowBQMau As Long
Dim LastRowBQKMau As Long
wsKCSKo.Select
Cells(csHangTieuDe, csCotMaVatTu).End(xlDown).Select
intSoLuongHang = ActiveCell.Row - csHangTieuDe
Set shBQMau = ActiveWorkbook.Worksheets("BQ_Mau")
Set shBQKMau = ActiveWorkbook.Worksheets("BQ_KMau")
LastRowBQMau = shBQMau.Cells(Rows.count, "B").End(xlUp).Row
LastRowBQKMau = shBQKMau.Cells(Rows.count, "B").End(xlUp).Row
For H = 0 To intSoLuongHang - 1
Set rgDuLieu = Cells(csHangTieuDe + 1 + H, csCotTonCuoiKCS)
If (rgDuLieu.Value <> 0) Then
intCount = intCount + 1
rgTieuDe_NgayChot.Offset(intCount, 0).Value = NgayChot
MaVatTu = Cells(rgDuLieu.Row(), csCotMaVatTu)
MaKho = csMaKhoPXKCS
For i = 7 To LastRowBQKMau
For j = 7 To LastRowBQMau
If shBQMau.Range("B" & j).Value = shBQKMau.Range("B" & i).Value Then
MaVatTu = shBQKMau.Range("B" & j).Value
Else
MaVatTu = shBQKMau.Range("B" & i).Value
End If
Next j
Next i
' Chuyen doi ma Phoi sang ma chi tiet thuong
Call DieuChinhMa(MaVatTu, "", "", MaVatTuDC, "", MaKhoDC)
rgTieuDe_MaVatTu.Offset(intCount, 0).Value = MaVatTuDC
rgTieuDe_MaKho.Offset(intCount, 0).Value = MaKho
MaBeMat = "_"
rgTieuDe_MaBeMat.Offset(intCount, 0).Value = MaBeMat
SoLuong = rgDuLieu.Value
If SoLuong < 0 Then
MsgBox ("Bang KCS, kiem tra lai ma " & MaVatTu & "-" & MaBeMat & " tai kho " & MaKho & " bi am " & SoLuong)
End If
rgTieuDe_SoLuong.Offset(intCount, 0).Value = SoLuong
End If
NextH8:
Next HCảm ơn Thầy đã giúp đỡ.
Có sẵn rồi mà sửa gì nữa.
Sarr = GetAllFile(path, 0) Sarr = GetAllFile(path, True)Mình đã edit thử rồi nhưng không search được, nếu để Sarr = GetAllFile(path, 0) thì search bình thường nhưng chỉ search folder hiện hành.
Bạn đưa file đã ê đít rồi mà không được tôi xem thử.
Tôi thử thì nó lấy cả trong thư mục con mà. Bạn kiểm tra lại xem file cần tìm có trong thư mục con không đã.
Vâng. Em cảm ơn Thầy.
Dạ đúng rồi ạ, e cảm ơn bác nhiều, nhưng e xin phép được nhờ thêm tí nữa ạ!
Hoàn hảo rồi Bác ạ
Option Explicit
Private Sub Tong_cong()
Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long
Dim R As Long, I As Long, J As Long, K As Long, C As Long
Dim sArr As Variant, dArr(1 To 10000, 1 To 40)
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
With Application
.CalculateBeforeSave = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.EnableCancelKey = xlErrorHandler
End With
With Sheets("Tong hop cong")
If CStr(.Range("C7")) <> "" Then
.Range("C8:BP7000").ClearContents
End If
sArr = .Range("B6").Resize(, 34).Value
For J = 4 To 34
If sArr(1, J) <> Empty Then
If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
End If
Next J
For I = 2 To UBound(sArr, 1)
If sArr(I, 1) <> Empty Then
Dic.Item(sArr(I, 1)) = I
End If
Next I
End With
For Each ws In Worksheets
If IsNumeric(ws.Name) Then
C = Col.Item(Val(ws.Name))
sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
For I = 1 To UBound(sArr, 1)
Tem=sarr(I,1)
If Len(sArr(I, 1)) = 5 And Left(sArr(I, 1), 1) < 3 And sArr(I, 17) > 0 Then
If Dic.exists(Tem) Then
K = K + 1
dArr(K, 1) = 1
dArr(K, 2) = sArr(I, 1)
dArr(K, 3) = sArr(I, 2)
End If
Rws = Dic.Item(Tem)
dArr(Rws, C) = sArr(I, 17)
End If
Next I
End If
Next ws
Sheets("Tong hop cong").Range("B8").Resize(K, 34) = dArr
Set Dic = Nothing
Set Col = Nothing
With Application
.CalculateBeforeSave = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.CalculateBeforeSave = True
.EnableCancelKey = xlInterrupt
End With
End Sub
Code của bạn có đoạn: Rws = Dic.Item(Tem)Mọi người xem giúp em code trong Module Tong_hop_cong này sai ở đâu mà không chạy
PHP:Option Explicit Private Sub Tong_cong() Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long Dim R As Long, I As Long, J As Long, K As Long, C As Long Dim sArr As Variant, dArr(1 To 10000, 1 To 40) Set Dic = CreateObject("Scripting.Dictionary") Set Col = CreateObject("Scripting.Dictionary") With Application .CalculateBeforeSave = False .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False .EnableCancelKey = xlErrorHandler End With With Sheets("Tong hop cong") If CStr(.Range("C7")) <> "" Then .Range("C8:BP7000").ClearContents End If sArr = .Range("B6").Resize(, 34).Value For J = 4 To 34 If sArr(1, J) <> Empty Then If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J End If Next J For I = 2 To UBound(sArr, 1) If sArr(I, 1) <> Empty Then Dic.Item(sArr(I, 1)) = I End If Next I End With For Each ws In Worksheets If IsNumeric(ws.Name) Then C = Col.Item(Val(ws.Name)) sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value For I = 1 To UBound(sArr, 1) If Len(sArr(I, 1)) = 5 And Left(sArr(I, 1), 1) < 3 And sArr(I, 17) > 0 Then If Dic.exists(sArr(I, 1)) Then K = K + 1 dArr(K, 1) = 1 dArr(K, 2) = sArr(I, 1) dArr(K, 3) = sArr(I, 2) End If Rws = Dic.Item(Tem) dArr(Rws, C) = sArr(I, 17) End If Next I End If Next ws Sheets("Tong hop cong").Range("B8").Resize(K, 34) = dArr Set Dic = Nothing Set Col = Nothing With Application .CalculateBeforeSave = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True .EnableEvents = True .CalculateBeforeSave = True .EnableCancelKey = xlInterrupt End With End Sub
Nguyên tắc là từ list ID cột B trong sheet Tong hop cong, tổng hợp toàn bộ công của các ngày sheet và add vào ngày tương ứng. Ví dụ em có ID 11111, em rà soát các ngày công 26 27 và 28, tại cột R của các sheet này nếu lớn hơn không thì add vào cột ngày tương ứng của sheet Tong hop cong. Từ bài lần trước của bạn hkphuong giúp đỡ cứ tưởng là đã hiểu sơ sơ về Dic rồi vậy mà không hiểu sao lại sai
Từ đoạn này
Option Explicit
Private Sub Tong_cong()
Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long
Dim R As Long, I As Long, J As Long, K As Long, C As Long
Dim sArr As Variant, dArr(1 To 10000, 1 To 40)
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
With Application
.CalculateBeforeSave = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.EnableCancelKey = xlErrorHandler
End With
With Sheets("Tong hop cong")
sArr = .Range("B6").Resize(100, 34).Value
For J = 4 To 34
If sArr(1, J) <> Empty Then
If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
End If
Next J
Set Dic = CreateObject("Scripting.Dictionary")
For I = 2 To UBound(sArr, 1)
Dic.Item(sArr(I, 1)) = I
Next
End With
For Each ws In Worksheets
If IsNumeric(ws.Name) Then
C = Col.Item(Val(ws.Name))
sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
For I = 1 To UBound(sArr, 1)
Tem = sArr(I, 1)
If Len(sArr(I, 1)) = 5 And Left(sArr(I, 1), 1) < 3 And sArr(I, 17) > 0 Then
If Dic.exists(Tem) Then
K = K + 1
dArr(K, 1) = sArr(I, 1)
dArr(K, 2) = sArr(I, 2)
dArr(K, 3) = sArr(I, 3)
End If
Rws = Dic.Item(Tem)
dArr(Rws, C) = sArr(I, 17)
End If
Next I
End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(K, 34) = dArr
Set Dic = Nothing
Set Col = Nothing
sArr = Range("A6").CurrentRegion
R = UBound(sArr, 1)
C = UBound(sArr, 2)
ReDim tArr(2 To R, 1 To 5)
For I = 2 To R
For J = 5 To C
If sArr(1, J) <= sArr(I, 1) Then
If IsNumeric(sArr(I, J)) Then
tArr(I, 1) = tArr(I, 1) + sArr(I, J)
ElseIf sArr(I, J) Like "1D" Then
tArr(I, 2) = Application.WorksheetFunction.Sum(tArr(I, 2) + Left(sArr(I, J), InStr(1, sArr(I, J), "D") - 1))
End If
ElseIf sArr(1, J) > sArr(I, 1) Then
If IsNumeric(sArr(I, J)) Then
tArr(I, 3) = tArr(I, 3) + sArr(I, J)
ElseIf sArr(I, J) Like "1D" Then
tArr(I, 4) = Application.WorksheetFunction.Sum(tArr(I, 4) + Left(sArr(I, J), InStr(1, sArr(I, J), "D") - 1))
End If
End If
Next J
tArr(I, 5) = tArr(I, 1) + tArr(I, 2) + tArr(I, 3) + tArr(I, 4)
Next I
Sheets("Tong hop cong").Range("AK7").Resize(I - 2, 5) = tArr
Sheets("Tong hop cong").Range("A6").CurrentRegion.Borders.LineStyle = xlContinuous
With Application
.CalculateBeforeSave = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.CalculateBeforeSave = True
.EnableCancelKey = xlInterrupt
End With
End SubMọi người xem giúp em code trong Module Tong_hop_cong này sai ở đâu mà không chạy
PHP:Option Explicit Private Sub Tong_cong() Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long Dim R As Long, I As Long, J As Long, K As Long, C As Long Dim sArr As Variant, dArr(1 To 10000, 1 To 40) Set Dic = CreateObject("Scripting.Dictionary") Set Col = CreateObject("Scripting.Dictionary") With Application .CalculateBeforeSave = False .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False .EnableCancelKey = xlErrorHandler End With With Sheets("Tong hop cong") If CStr(.Range("C7")) <> "" Then .Range("C8:BP7000").ClearContents End If sArr = .Range("B6").Resize(, 34).Value For J = 4 To 34 If sArr(1, J) <> Empty Then If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J End If Next J For I = 2 To UBound(sArr, 1) If sArr(I, 1) <> Empty Then Dic.Item(sArr(I, 1)) = I End If Next I End With For Each ws In Worksheets If IsNumeric(ws.Name) Then C = Col.Item(Val(ws.Name)) sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value For I = 1 To UBound(sArr, 1) Tem=sarr(I,1) If Len(sArr(I, 1)) = 5 And Left(sArr(I, 1), 1) < 3 And sArr(I, 17) > 0 Then If Dic.exists(Tem) Then K = K + 1 dArr(K, 1) = 1 dArr(K, 2) = sArr(I, 1) dArr(K, 3) = sArr(I, 2) End If Rws = Dic.Item(Tem) dArr(Rws, C) = sArr(I, 17) End If Next I End If Next ws Sheets("Tong hop cong").Range("B8").Resize(K, 34) = dArr Set Dic = Nothing Set Col = Nothing With Application .CalculateBeforeSave = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True .EnableEvents = True .CalculateBeforeSave = True .EnableCancelKey = xlInterrupt End With End Sub
Nguyên tắc là từ list ID cột B trong sheet Tong hop cong, tổng hợp toàn bộ công của các ngày sheet và add vào ngày tương ứng. Ví dụ em có ID 11111, em rà soát các ngày công 26 27 và 28, tại cột R của các sheet này nếu lớn hơn không thì add vào cột ngày tương ứng của sheet Tong hop cong. Từ bài lần trước của bạn hkphuong giúp đỡ cứ tưởng là đã hiểu sơ sơ về Dic rồi vậy mà không hiểu sao lại sai
Em sửa lại code bài #1248 rồi mà vẫn không được. Vẫn báo lỗi như vậy. Không biết còn sai ở đâu.
Bạn cần gì nêu cụ thể, viết mới tiện hơn
- Em chỉ lấy 8 dòng quy định trước. Từ list ID này sẽ lấy dữ liệu ở cột R của các sheet 26 27 28 nếu có. (26 27 28 là dữ liệu chấm công của lần lượt các ngày 26 27 28). ID có thể có ở sheet này không có ở sheet kia hoặc đều có ở 3 sheet nhưng chắc chắn tối thiểu sẽ có ở 1 trong 3 sheet 26 27 28
Private Sub Tong_cong()
Dim Dic As Object, ws As Worksheet, Tem As String
Dim ngayd As Long, I As Long, K As Long, C As Long
Dim sArr As Variant, dArr As Variant
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Tong hop cong")
ngayd = Day(.Range("E6").Value)
If CStr(.Range("C7")) <> "" Then
.Range("C7:BP7000").ClearContents
End If
sArr = .Range("B7", Range("B65000").End(xlUp)).Value
ReDim dArr(1 To UBound(sArr), 1 To 31)
For I = 1 To UBound(sArr, 1)
If sArr(I, 1) <> Empty Then
Dic.Item(CStr(sArr(I, 1))) = I
End If
Next I
End With
For Each ws In Worksheets
If IsNumeric(ws.Name) Then
C = ((Val(ws.Name) - ngayd) Mod 31) + 4
sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
For I = 1 To UBound(sArr, 1)
If sArr(I, 17) > 0 Then
Tem = sArr(I, 1)
If Dic.exists(CStr(Tem)) Then
K = Dic.Item(Tem)
dArr(K, 1) = Tem
dArr(K, 2) = sArr(I, 2)
dArr(K, 3) = sArr(I, 3)
dArr(K, C) = sArr(I, 17)
End If
End If
Next I
End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr), 34) = dArr
Set Dic = Nothing
Application.ScreenUpdating = True
End SubTại ngày 23 24 25 xuất hiện #N/A anh ơi.
Type mismatch ở dòng If sArr(I, 1) <> Empty cũng hơi lạ bạn có đổi khai báo Dim không? thử If Len(sArr(I, 1)) > 0 Then
Mình quên nhìn các cột cuối
Private Sub Tong_cong()
Dim Dic As Object, ws As Worksheet, Tem As String
Dim ngayd As Long, I As Long, K As Long, C As Long
Dim sArr As Variant, dArr As Variant
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Tong hop cong")
ngayd = Day(.Range("E6").Value)
If CStr(.Range("C7")) <> "" Then
.Range("C7:BP7000").ClearContents
End If
sArr = .Range("B7", .Range("B65000").End(xlUp)).Value
ReDim dArr(1 To UBound(sArr), 1 To 34)
For I = 1 To UBound(sArr, 1)
If Len(sArr(I, 1)) > 0 Then
Dic.Item(CStr(sArr(I, 1))) = I
End If
Next I
End With
For Each ws In Worksheets
If IsNumeric(ws.Name) Then
C = ((Val(ws.Name) + 31 - ngayd) Mod 31) + 4
sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
For I = 1 To UBound(sArr, 1)
If sArr(I, 17) > 0 Then
Tem = sArr(I, 1)
If Dic.exists(CStr(Tem)) Then
K = Dic.Item(Tem)
dArr(K, 1) = Tem
dArr(K, 2) = sArr(I, 2)
dArr(K, 3) = sArr(I, 3)
dArr(K, C) = sArr(I, 17)
End If
End If
Next I
End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr), 34) = dArr
Set Dic = Nothing
Application.ScreenUpdating = True
End SubTừ code của bạn mình viết theo ý giữ nguyên Col như sau:
Option Explicit
Private Sub Tong_cong()
Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long
Dim R As Long, I As Long, J As Long, K As Long, C As Long
Dim sArr As Variant
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
With Application
.CalculateBeforeSave = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.EnableCancelKey = xlErrorHandler
End With
With Sheets("Tong hop cong")
If CStr(.Range("C7")) <> "" Then
.Range("C8:BP7000").ClearContents
End If
sArr = .Range("B6", .Range("B65000").End(xlUp)).Resize(, 34).Value
ReDim dArr(2 To UBound(sArr, 1), 1 To 34)
For J = 4 To 34
If sArr(1, J) <> Empty Then
If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
End If
Next J
For I = 2 To UBound(sArr, 1)
If Len(sArr(I, 1)) > 0 Then
Dic.Item(CStr(sArr(I, 1))) = I
End If
Next I
End With
For Each ws In Worksheets
If IsNumeric(ws.Name) Then
C = Col.Item(Val(ws.Name))
sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
For I = 1 To UBound(sArr, 1)
Tem = sArr(I, 1)
If Dic.exists(CStr(Tem)) Then
K = Dic.Item(Tem)
dArr(K, 1) = Tem
dArr(K, 2) = sArr(I, 2)
dArr(K, 3) = sArr(I, 3)
dArr(K, C) = sArr(I, 17)
End If
Next I
End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr) - 1, 34) = dArr
Set Dic = Nothing
Set Col = Nothing
With Application
.CalculateBeforeSave = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.CalculateBeforeSave = True
.EnableCancelKey = xlInterrupt
End With
End SubChỉnh lại dArr cho hợp lý hơn
Private Sub Tong_cong1()
Dim Dic As Object, Col As Object, ws As Worksheet, Tem As String, Rws As Long
Dim R As Long, I As Long, J As Long, K As Long, C As Long
Dim sArr As Variant
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
With Application
.CalculateBeforeSave = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.EnableCancelKey = xlErrorHandler
End With
With Sheets("Tong hop cong")
If CStr(.Range("C7")) <> "" Then
.Range("C8:BP7000").ClearContents
End If
sArr = .Range("B6", .Range("B65000").End(xlUp)).Resize(, 34).Value
ReDim dArr(1 To UBound(sArr, 1) - 1, 1 To 34)
For J = 4 To 34
If sArr(1, J) <> Empty Then
If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
End If
Next J
For I = 2 To UBound(sArr, 1)
If Len(sArr(I, 1)) > 0 Then
Dic.Item(CStr(sArr(I, 1))) = I - 1
End If
Next I
End With
For Each ws In Worksheets
If IsNumeric(ws.Name) Then
C = Col.Item(Val(ws.Name))
sArr = ws.Range("B2", ws.Range("B65000").End(xlUp)).Resize(, 17).Value
For I = 1 To UBound(sArr, 1)
Tem = sArr(I, 1)
If Dic.exists(CStr(Tem)) Then
K = Dic.Item(Tem)
dArr(K, 1) = Tem
dArr(K, 2) = sArr(I, 2)
dArr(K, 3) = sArr(I, 3)
dArr(K, C) = sArr(I, 17)
End If
Next I
End If
Next ws
Sheets("Tong hop cong").Range("B7").Resize(UBound(dArr), 34) = dArr
Set Dic = Nothing
Set Col = Nothing
With Application
.CalculateBeforeSave = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.CalculateBeforeSave = True
.EnableCancelKey = xlInterrupt
End With
End SubsArr lấy từ dòng 6, dArr lấy từ dòng 7,nên số dòng của dArr ít hơn sArr 1 dòng, nên khai báo dArr:
With Sheets("Tong hop cong")
If CStr(.Range("C7")) <> "" Then
.Range("C8:BP7000").ClearContents
End If
sArr = .Range("B6").Resize(, 34).Value 'lay cot ngay
For J = 4 To 34
If sArr(1, J) <> Empty Then
If IsDate(sArr(1, J)) Then Col.Item(Day(sArr(1, J))) = J
End If
Next J
sArr = .Range("B7", .Range("B65000").End(xlUp)).Value 'lay dong
ReDim dArr(1 To UBound(sArr, 1), 1 To 34)
For I = 1 To UBound(sArr, 1)
If Len(sArr(I, 1)) > 0 Then
Dic.Item(CStr(sArr(I, 1))) = I
End If
Next I
End With
Bạn chạy Sub này thử
Sub Tonghopvattu()
Application.ScreenUpdating = False
Dim Dic As Object, Tem As String
Dim sArr(), dArr(), tArr(), Er As Long
Dim I As Long, J As Long, N As Long, K As Long, LaMa As Long, Stt As Long, Rws As Long
Set Dic = CreateObject("scripting.Dictionary")
With Sheets("xuatDL")
sArr = .Range("C7", .Range("C65536").End(3)).Resize(, 5).Value
tArr = .Range("L1:N1").Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
With Sheets("THVT")
With .Range("A6:I1000")
.ClearContents: .Interior.ColorIndex = 0: .Borders.LineStyle = 0: .Font.Bold = False
End With
For N = 1 To 3
Stt = 0: LaMa = LaMa + 1: K = K + 1
dArr(K, 1) = ChrW(LaMa + 64): dArr(K, 2) = tArr(1, N)
.Range("A" & K + 5).Resize(, 9).Interior.ColorIndex = 20
.Range("A" & K + 5).Resize(, 9).Font.Bold = True
For I = 1 To UBound(sArr, 1)
If sArr(I, 1) <> Empty Then
If Left(sArr(I, 1), 1) = Left(tArr(1, N), 1) Then
Tem = sArr(I, 1)
If Not Dic.Exists(Tem) Then
K = K + 1: Stt = Stt + 1
Dic.Add Tem, K
dArr(K, 1) = Stt: dArr(K, 2) = sArr(I, 1)
dArr(K, 3) = sArr(I, 2): dArr(K, 4) = sArr(I, 3)
dArr(K, 5) = sArr(I, 5)
Else
Rws = Dic.Item(Tem): dArr(Rws, 5) = dArr(Rws, 5) + sArr(I, 5)
End If
End If
End If
Next I
Next N
.Range("A6").Resize(K, 5) = dArr:
.Range("A6").Resize(K, 9).Borders.LineStyle = 1
If Not IsNumeric(.Range("A65536").End(3)) Then .Range("A65536").End(3).EntireRow.Delete
Er = .Range("A65536").End(3).Row
For I = Er To 6 Step -1
If Not IsNumeric(.Range("A" & I)) Then
.Range("B" & I + 1 & ":I" & Er).Sort Key1:=.Range("C" & I + 1)
Er = I - 1
End If
Next I
End With
Set Dic = Nothing
End SubCám ơn chị rất nhiều. chị có thể chỉnh sửa bài #1245 giúp e được không?
Các bạn và bạn PacificPR giúp mình thêm code này nữa nhé!
có ai không, giúp mình với đi
mình tìm được trên diễn đàn này, và có chỉnh sữa cho phù hợp hơn tí thôi. có mấy code khóa quá nên nhờ diễn đàn giúpHình như cái File này em đã gặp ở đâu trên diễn đàn mình roài thì phải. (Hình như bài của anh "Sơn thủ bạc")
Bạn qua đây có bài giống của bạn nè
Mình có qua đó xem rồi và cũng timif được 1 1file gần tương tự nhưng mình chỉnh lại cứ báo lỗi.
Private Sub cmdThem_Click()
Dim Lr As Long, stt As Long
Lr = Sheet7.Cells(Rows.Count, "B").End(3).Row
If Me.cmbMaTS = "" Then
MsgBox ("Ban chua chon kieu ma tai san")
Me.cmbMaTS.SetFocus
Exit Sub
End If
If Me.txtMaTS = "" Then
MsgBox ("Ban chua nhap ma tai san")
Me.txtMaTS.SetFocus
Exit Sub
End If
With Sheet7
stt = Application.WorksheetFunction.CountIf(.Range("$B$2:B" & Lr), Me.cmbMaTS.Value & " * ")
Select Case stt
Case Is < 10
.Range("B" & Lr + 1) = StrConv(cmbMaTS.Value & Me.txtMaTS.Value & "00" & stt + 1, vbUpperCase)
Case Is < 100
.Range("B" & Lr + 1) = StrConv(cmbMaTS.Value & Me.txtMaTS.Value & "0" & stt + 1, vbUpperCase)
Case Else
.Range("B" & Lr + 1) = StrConv(cmbMaTS.Value & Me.txtMaTS.Value & stt + 1, vbUpperCase)
End Select
End With
End Substt = Application.WorksheetFunction.CountIf(.Range("$B$2:B" & Lr), Me.cmbMaTS.Value & " * ")
Bạn thêm vào 2 dòng lệnh sau, nếu đặt biến ngay từ đầu thì tốt hơn (t = Ubound(...))
For i = 1 To UBound(arr1, 1)
If i < UBound(arr, 1) + 1 Then '<=== Them vao
If DateAdd("m", 13, arr1(i, 1)) >= Date Then
k1 = k1 + 1
res1(k1, 1) = arr1(i, 1)
res1(k1, 2) = arr1(i, 2)
End If
End If '<=== Them vao
Next iBác ơi, vậy trong trường hợp i>ubound(arr,1) thì làm thế nào?
Như file của bạn thì tôi tạm hiểu rằng bạn sử dụng 2 Array, 1 cho cột A (arr) và 1 cho cột X (arr1)
Private Sub txtTim_Change()
If Me.txtTim = "" Then
Me.lsbTim.Visible = False
ElseIf Me.txtTim.Value = "?" Then
nhaplieu.Hide (nhaplieu form hiện hành muốn ẩn)
nhaptaisan.Show (nhập tài sản form muốn hiện)
Else
Me.lsbTim.Visible = True
Sub CopyDulieu()
F.Range("D4:D8,D10:D52,D54:D77,D82:D87").ClearContents
F.Range("I4:I8").Copy
F.Range("D4:D8").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
F.Range("I10:I52").Copy
F.Range("D10:D52").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
F.Range("I54:I77").Copy
F.Range("D54:D77").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
F.Range("I82:I87").Copy
F.Range("D82:D87").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
F.Range("D3").Activate
Application.CutCopyMode = False
End SubThì đó là cái em đang bị lỗi, cái em muốn là 2 array đó độc lập với nhau, ngày tháng trên mỗi array >13 tháng thì sẽ bị loại bỏ, vì số liệu bên em nhập liên tục nên nếu không bỏ dữ liệu cũ thì sẽ dài mãi file ngày càng nặng nề.
Oh, mắt mũi kém quá, em check mãi Ko ra lỗi. Tks bác nhé
Private Sub txtTim_Change()
If Me.txtTim = "" Then
Me.lsbTim.Visible = False
ElseIf Me.txtTim.Value = "?" Then
nhaplieu.Hide
nhaptaisan.Show
Else
Me.lsbTim.Visible = True
Dim arr, sArray
sArray = Sheet4.Range("A2:E" & Sheet4.[B65000].End(xlUp).Row)
On Error Resume Next
If Len(Trim(txtTim.Value)) = 0 Then Me.lsbTim.List() = sArray: Exit Sub
arr = Filter2DArray(sArray, 2, "*" & txtTim.Value & "*", False) 'goc la so 1 "cot tim kiem)
If Not IsArray(arr) Then
arr = Filter2DArray(sArray, 3, "*" & txtTim.Value & "*", False)
If Not IsArray(arr) Then lsbTim.Clear: Exit Sub
End If
Me.lsbTim.List() = IIf(Trim(txtTim.Text) = "", sArray, arr)
End If
End Sub
Sub Phan_Bo1()
Dim a(), lRow As Long, sMatch As String, eMatch As String
Dim Res(), TT As Double, KH As Double, i As Long, j As Long
With Sheet5
lRow = .Range("A" & Rows.Count).End(xlUp).Row
a = .Range("A7:S" & lRow).Value
lRow = UBound(a, 1)
ReDim Res(1 To lRow, 1 To 1)
For i = 1 To lRow
sMatch = a(i, 1) & "#" & a(i, 2) & "#" & a(i, 3) & "#" & a(i, 4) & "#" & a(i, 5)
TT = 0: KH = 0
'Xac dinh so Tieu_thu
For j = 1 To lRow
eMatch = a(j, 1) & "#" & a(j, 2) & "#" & a(j, 3) & "#" & a(j, 4) & "#" & a(j, 5)
If sMatch = eMatch Then TT = TT + a(j, 18)
Next j
'Xac dinh so Ke_hoach
For j = 1 To lRow
eMatch = a(j, 1) & "#" & a(j, 2) & "#" & a(j, 3) & "#" & a(j, 4) & "#" & a(j, 5)
If sMatch = eMatch Then KH = KH + a(j, 19)
Next j
'Tinh Phan_bo
Res(i, 1) = a(i, 19) * TT / KH
Next i
.Range("U7").ClearContents
.Range("U7").Resize(lRow, 1) = Res
End With
End SubTôi chỉ nhìn công thức cột T để viết thôi nhé, Tốc độ thì không có dữ liệu nênkhông biết được.
Public Sub S_GPE()
Dim sArr(), dArr(), tArr(), I As Long, K As Long, R As Long, Tem As String, Rws As Double
sArr = Range("A7", Range("A7").End(xlDown)).Resize(, 19).Value
R = UBound(sArr)
ReDim tArr(1 To R, 1 To 2)
ReDim dArr(1 To R, 1 To 1)
With CreateObject("Scripting.Dictionary")
For I = 1 To R
Tem = sArr(I, 1) & "#" & sArr(I, 2) & "#" & sArr(I, 4) & "#" & sArr(I, 5)
If Not .Exists(Tem) Then
K = K + 1
.Item(Tem) = K
tArr(K, 1) = sArr(I, 18)
End If
Rws = .Item(Tem)
tArr(Rws, 2) = tArr(Rws, 2) + sArr(I, 19)
Next I
For I = 1 To R
Tem = sArr(I, 1) & "#" & sArr(I, 2) & "#" & sArr(I, 4) & "#" & sArr(I, 5)
Rws = .Item(Tem)
dArr(I, 1) = tArr(Rws, 1) / tArr(Rws, 2) * sArr(I, 19)
Next I
End With
Range("Y7").Resize(R) = dArr
End SubThank!, e đã chỉnh được rồi, do sheet khối lượng có khoảng hở mà ko để ý.
Private Sub Worksheet_Change(ByVal Target As Range)
If [D1] = 0 Then
CommandButton1.Visible = False
Exit Sub
End If
If [D1] >= 0 Then
CommandButton1.Visible = True
Exit Sub
End If
If [G1] = 0 Then
CommandButton2.Visible = False
Exit Sub
End If
If [G1] >= 0 Then
CommandButton2.Visible = True
Exit Sub
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If [D1] = 0 Then
CommandButton1.Visible = False
Exit Sub
End If
If [D1] >= 0 Then
CommandButton1.Visible = True
Exit Sub
End If
End Sub
Vậy sửa lại thế này xem sao.
Private Sub Worksheet_Change(ByVal Target As Range)
If [D1] = 0 Then
CommandButton1.Visible = False
Else
CommandButton1.Visible = True
End If
If [G1] = 0 Then
CommandButton2.Visible = False
Else
CommandButton2.Visible = True
End If
End SubCode của bạn ngắn gọn ,chạy Ok ,Nhưng nếu 2 nút CommandButton mà dùng chung một điều kiện tại D1 ,Tức là khi tại D1 có dữ liệu thì
Mình thấy nó hiện lên MsgBox thông báo có công thức =số A*B nhưng nó không chạy bạn ơi
Dữ liệu được thêm vào sheet TonVatTu, lấy dữ liệu từ 3 sheet BTP1, Son_PX1, Son_cty. Dữ liệu trong sheet Son_PX1 trùng mã vật tư với sheet BTP1 và cột Sơn tím thuộc sheet Son_PX1 trùng với cột BTP2.7S1 trong sheet BTP1 thì sẽ lấy dữ liệu trong sheet Son_PX1. Tương tự trong sheet Son_cty nếu trùng như thế thì sẽ lấy dữ liệu trong sheet Son_cty và bỏ qua dữ liệu trong sheet BTP1 ạ.
' LAY SO LIEU SHEET BTP1
wsBTP1.Select
Cells(csHangTieuDe, csCotMaVatTu).End(xlDown).Select
intSoLuongHang = ActiveCell.Row - csHangTieuDe
Cells(csHangTieuDe, csCotBatDauChuyen).End(xlToRight).Select
intSoLuongCot = ActiveCell.Column - csCotBatDauChuyen + 1
For H = 0 To intSoLuongHang - 1
For C = 0 To intSoLuongCot - 1
Set rgDuLieu = Cells(csHangTieuDe + 1 + H, csCotBatDauChuyen + C)
If (rgDuLieu.Value <> 0) Then
intCount = intCount + 1
rgTieuDe_NgayChot.Offset(intCount, 0).Value = NgayChot
MaBeMat = "_"
rgTieuDe_MaBeMat.Offset(intCount, 0).Value = MaBeMat
' Chuyen doi ma Phoi sang ma chi tiet thuong
MaVatTu = Cells(rgDuLieu.Row(), csCotMaVatTu)
MaKho = Cells(csHangTieuDe, rgDuLieu.Column())
Call DieuChinhMa(MaVatTu, "", MaKho, MaVatTuDC, "", MaKhoDC)
rgTieuDe_MaVatTu.Offset(intCount, 0).Value = MaVatTuDC
rgTieuDe_MaKho.Offset(intCount, 0).Value = MaKhoDC
' So luong
DonVi = Cells(rgDuLieu.Row(), csCotDonVi)
SoLuong = rgDuLieu.Value
If SoLuong < 0 Then
MsgBox ("Bang BTP1, kiem tra lai ma " & MaVatTu & " tai kho " & MaKho & " bi am " & SoLuong)
End If
If DonVi <> "kg" Then
rgTieuDe_SoLuong.Offset(intCount, 0).Value = SoLuong
Else
'Quy doi so luong
rgTieuDe_SoLuong.Offset(intCount, 0).Value = QuyDoiVatTuTuKgSangCai(MaVatTu, SoLuong)
End If
End If
NextC1:
Next C
NextH1:
Next H
' LAY SO LIEU SHEET Son_Cty
wsSonMaCty.Select
Cells(csHangTieuDe, csCotMaVatTu).End(xlDown).Select
intSoLuongHang = ActiveCell.Row - csHangTieuDe
Cells(csHangTieuDe, csCotBatDauChuyen).End(xlToRight).Select
intSoLuongCot = ActiveCell.Column - csCotBatDauChuyen + 1
For H = 0 To intSoLuongHang - 1
For C = 0 To intSoLuongCot - 1
Set rgDuLieu = Cells(csHangTieuDe + 1 + H, csCotBatDauChuyen + C)
If (rgDuLieu.Value <> 0) Then
intCount = intCount + 1
rgTieuDe_NgayChot.Offset(intCount, 0).Value = NgayChot
MaVatTu = Cells(rgDuLieu.Row(), csCotMaVatTu)
' DOI TEN BE MAT SANG MA BE MAT
MaBeMat = WorksheetFunction.VLookup(Cells(csHangTieuDe, rgDuLieu.Column()), tblMaBeMatChiTiet, 2, 0)
MaKho = csMaKhoSonCty
' Chuyen doi ma Phoi sang ma chi tiet thuong
Call DieuChinhMa(MaVatTu, MaBeMat, MaKho, MaVatTuDC, MaBeMatDC, MaKhoDC)
rgTieuDe_MaVatTu.Offset(intCount, 0).Value = MaVatTuDC
rgTieuDe_MaBeMat.Offset(intCount, 0).Value = MaBeMatDC
rgTieuDe_MaKho.Offset(intCount, 0).Value = MaKhoDC
' So luong
DonVi = Cells(rgDuLieu.Row(), csCotDonVi)
SoLuong = rgDuLieu.Value
If SoLuong < 0 Then
MsgBox ("Bang Son_Cty, kiem tra lai ma " & MaVatTu & "-" & MaBeMat & " tai kho " & MaKho & " bi am " & SoLuong)
End If
If DonVi <> "kg" Then
rgTieuDe_SoLuong.Offset(intCount, 0).Value = SoLuong
Else
'Quy doi so luong
rgTieuDe_SoLuong.Offset(intCount, 0).Value = QuyDoiVatTuTuKgSangCai(MaVatTu, SoLuong)
End If
End If
NextC3:
Next C
NextH3:
Next H
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LAY SO LIEU SHEET Son_PX1
wsSonMaPX1.Select
Cells(csHangTieuDe, csCotMaVatTu).End(xlDown).Select
intSoLuongHang = ActiveCell.Row - csHangTieuDe
Cells(csHangTieuDe, csCotBatDauChuyen).End(xlToRight).Select
intSoLuongCot = ActiveCell.Column - csCotBatDauChuyen + 1
For H = 0 To intSoLuongHang - 1
For C = 0 To intSoLuongCot - 1
Set rgDuLieu = Cells(csHangTieuDe + 1 + H, csCotBatDauChuyen + C)
If (rgDuLieu.Value <> 0) Then
intCount = intCount + 1
rgTieuDe_NgayChot.Offset(intCount, 0).Value = NgayChot
MaVatTu = Cells(rgDuLieu.Row(), csCotMaVatTu)
' DOI TEN BE MAT SANG MA BE MAT
MaBeMat = WorksheetFunction.VLookup(Cells(csHangTieuDe, rgDuLieu.Column()), tblMaBeMatChiTiet, 2, 0)
MaKho = csMaKhoSonPX1
' Chuyen doi ma Phoi sang ma chi tiet thuong
Call DieuChinhMa(MaVatTu, MaBeMat, MaKho, MaVatTuDC, MaBeMatDC, MaKhoDC)
rgTieuDe_MaVatTu.Offset(intCount, 0).Value = MaVatTuDC
rgTieuDe_MaBeMat.Offset(intCount, 0).Value = MaBeMatDC
rgTieuDe_MaKho.Offset(intCount, 0).Value = MaKhoDC
' So luong
DonVi = Cells(rgDuLieu.Row(), csCotDonVi)
SoLuong = rgDuLieu.Value
If SoLuong < 0 Then
MsgBox ("Bang Son_PX1, kiem tra lai ma " & MaVatTu & "-" & MaBeMat & " tai kho " & MaKho & " bi am " & SoLuong)
End If
If DonVi <> "kg" Then
rgTieuDe_SoLuong.Offset(intCount, 0).Value = SoLuong
Else
'Quy doi so luong
rgTieuDe_SoLuong.Offset(intCount, 0).Value = QuyDoiVatTuTuKgSangCai(MaVatTu, SoLuong)
End If
End If
NextC4:
Next C
NextH4:
Next H
