Bạn muốn thoát Excel thì dùng thủ tục này cho nút Đóng:
Private Sub cmdThoat_Click()
Unload Me
ThisWorkbook.Save
If Workbooks.Count = 1 Then
Application.Quit
Else
Application.Visible = True
ThisWorkbook.Close False
End If
End Sub
Cám ơn Thầy rất nhiều! em cũng không hiểu làm sao em mở vẫn bị mờ, có thể máy của em bị lỗi gì đó, em sẽ thử sang máy khác xem thế nào. Một lần nữa cám ơn Thầy! và chúc Thầy cùng gia đình luôn mạnh khỏe, hạnh phúc. Trân trọng
Function USD(ByVal Series As String) As String
Application.Volatile
Series = Replace(Series, " ", "")
If Not IsNumeric(Series) Then Exit Function
Dim IsNegative As Boolean
If Left(Series, 1) = "-" Then
IsNegative = True
Series = Replace(Series, "-", "")
End If
If Series = "" Then Exit Function
If Val(Series) = 0 Then
USD = "US dollar zero."
Exit Function
ElseIf Val(Series) = 1 Then
USD = "US dollar one."
Exit Function
End If
If Val(Series) >= 1E+15 Then
USD = "No result (huge number)."
Exit Function
End If
Static DigitString
Dim Deci As String, Digi As String
Dim arrUnits, SplitArr, SplitArray, JoinArr()
Dim i As Long, n As Long, m As Long, Ubd As Long
arrUnits = DecimalSpelling(Series)
Digi = arrUnits(0)
Deci = arrUnits(1)
If Digi = 0 Then
USD = "US dollar zero" & Deci
ElseIf Digi = 1 Then
USD = "US dollar one" & Deci
Else
If Not IsArray(DigitString) Then
DigitString = Array("Hundred", " thousand", " million", " billion", " trillion")
End If
SplitArray = Split(Digi, ",")
Ubd = UBound(SplitArray)
ReDim SplitArr(0 To Ubd)
For i = Ubd To 0 Step -1
SplitArr(n) = SplitArray(i)
n = n + 1
Next
Dim Itm As String
For i = Ubd To 0 Step -1
Itm = SplitArr(i)
If i = 0 Then
ReDim Preserve JoinArr(0 To m)
JoinArr(m) = Hundreds(Itm)
Else
ReDim Preserve JoinArr(0 To m)
JoinArr(m) = Hundreds(Itm) & DigitString(i)
End If
m = m + 1
Next
Digi = Join(JoinArr, " ")
If Left(Digi, 4) = "zero" Then
Digi = "US dollar " & Digi
Else
Digi = "US dollars " & Digi
End If
If Deci > "" Then
USD = Digi & Deci
Else
USD = Digi & "."
End If
End If
If IsNegative Then
USD = "(Negative) " & USD 'You can use "Minus" instead of "Negative"
End If
End Function
For i = 1 To j Step 1
If Selection.Cells(i, 2).Value = Sheets("KQ Theo doi").Cells(1, 6).Value Or _
Selection.Cells(i, 4).Value = Sheets("KQ Theo doi").Cells(1, 6).Value Then
iR = iR + 1
Arr(iR, 1) = Selection.Cells(i, 1).Value
Arr(iR, 2) = Selection.Cells(i, 2).Value
Arr(iR, 3) = Selection.Cells(i, 3).Value
Arr(iR, 4) = Selection.Cells(i, 4).Value
Arr(iR, 5) = Selection.Cells(i, 5).Value
Arr(iR, 6) = Selection.Cells(i, 6).Value
End If
Next iSub KQTheodi_Chay()
Dim Arr(1 To 41, 1 To 6), i, jcount As Long
Dim iR As Long, EndRw As Long, SArr()
Range("A25:F65").ClearContents
EndRw = Sheets("PL Result").Range("A4").End(xlDown).Row
SArr = Sheets("PL Result").Range("A4:F" & EndRw).Value
jcount = UBound(SArr, 1)
For i = 1 To jcount Step 1
If SArr(i, 2) = Cells(1, 6).Value Or _
SArr(i, 4) = Cells(1, 6).Value Then
iR = iR + 1
For k = 1 To 6
Arr(iR, k) = SArr(i, k)
Next k
End If
Next i
Range("A25:F65").Value = Arr
End Subhehe,
,Private i_fc1 As i_fc
Private i_fc2 As i_fc
Private fl As Boolean
Private Sub ini()
fl = True
Set i_fc1 = New i_fc
Set i_fc2 = New i_fc
End Sub
'##########
Function ham1(c As Range)
Dim i As Long
If Not fl Then Call ini
For i = 0 To 100000
i = i
Next i
i_fc2.ii_fc = c.Value - 1
ham1 = c.Value
End Function
'##########
Function ham2(c As Range)
If Not fl Then Call ini
i_fc1.ii_fc = c.Value
ham2 = i_fc2.ii_fc
End Function
Vấn đề thứ nhất: Với Excel 2007 trở lên thì có cột HAM nên HAM1, HAM2 là những địa chỉ ô, do đó Excel sẽ không chịu để cho bạn đặt chúng thành tên hàm. Bạn sửa lại thành Ham_1, Ham_2 chẳng hạn thì sẽ được.
Em nó đây ạ, các bác xử lý vụ này giúp em với.
mình đã mở khóa toàn bộ các sheet + Project VBA (mà sao chỉ thấy toàn là code tại module của sheet
)Trước hết em cảm ơn bác nhiều nha.mình đã mở khóa toàn bộ các sheet + Project VBA (mà sao chỉ thấy toàn là code tại module của sheet
file của bạn đây: https://www.mediafire.com/?ln09419fa1gk222
Nếu các sheet đó có cấu trúc giống nhau --> bạn có thể gộp chung bằng cách dùng sự kiện Workbook_SheetChange tại Module ThisWorkbook thay vì cài ở từng sheet như thế.Trước hết em cảm ơn bác nhiều nha.
file này của em như tiêu đề của nó tức là nhật kí của từng ngày, vì thế em viết code cho 1 sheet rồi move and copi thành 31 sheet. Mặt khác trong file có các sheet ko chứa code lên em ko dùng Macro cho toàn bộ file trong sheet được.
- mình có search trên diễn đàn GPE (vài trang đầu) về cách mở "Project is Unviewable" nhưng ko thấy và đã tìm trên Google thì có giải thích chi tiết tại đây "Project is Unviewable" - Excel add-in (#4) (www.mrexcel.com). Riêng bài đó mình chỉ góp ý với bạn, bước 5 --> phải dùng 1 "công cụ khác" để kiểm tra pass của VBA-Project (trên GPE ko được phép share, bạn có thể nhắn tin riêng cho mìnhBác có thể hướng dẫn em cách bác unclok file trên được ko? em ko phải người nhập dữ liệu lên em sợ file của em lại bị như thế nhiều lần nữa lại phải mang làm phiền bác thì ngại lắm.
)Hi, em lập pass như vậy là do bảng này dùng cho nhiều người, người biết và không biết exel đều có. mà bảng này cần dữ liệu hàng giờ. em sợ mọi người nhập sai rồi tự sửa nhưng sửa không đúng bệnh thì toàn bộ hệ thống liên quan coi như ko làm việc bác ạ.Nếu các sheet đó có cấu trúc giống nhau --> bạn có thể gộp chung bằng cách dùng sự kiện Workbook_SheetChange tại Module ThisWorkbook thay vì cài ở từng sheet như thế.
- mình có search trên diễn đàn GPE (vài trang đầu) về cách mở "Project is Unviewable" nhưng ko thấy và đã tìm trên Google thì có giải thích chi tiết tại đây "Project is Unviewable" - Excel add-in (#4) (www.mrexcel.com). Riêng bài đó mình chỉ góp ý với bạn, bước 5 --> phải dùng 1 "công cụ khác" để kiểm tra pass của VBA-Project (trên GPE ko được phép share, bạn có thể nhắn tin riêng cho mình
- khi bảo vệ 1 file Excel để tránh người bình thường đụng vào Code thì bạn chỉ cần đặt pass cho VBA-Project là đủ (ko cần gì phải "khóa kỹ" như vậy)
hehe,
- thấy bạn vọc tới vọc lui cái này lâu nay rồi mà vẫn "chưa nhuyễn" được
- khi làm việc với các ActiveX Controls tại sheet sẽ gặp khá nhiều hạn chế (đặc biệt là các sự kiện tại Sheet)
---> để giải quyết triệt để và phải tính đến chuyện lâu dài về sau, thay vì theo đuổi cái đó bạn chịu khó đi thêm bước nữa là làm việc trên UserForm --> rất nhiều ưu điểm.
If Target.Column = 3 Then
Range("E" & Target.Row).Select
'hoac: Target.Offset(, 2).Select
End If
If Target.Column = 5 Then Target.Offset(, 1).Select
If Target.Column = 6 Then Target.Offset(1, -3).SelectTôi thấy bạn cứ lòng vòng hoài với các controls trong sheet, tôi thấy mệt mỏi cho bạn quá! Tôi làm cái file này trên UserForm để bạn dễ dàng nhập dữ liệu.
Sub loaddata(DBFullName As String, TargetRange As Range)
Dim i, J, Cco
Dim cn As ADODB.Connection, Rs As ADODB.Recordset, intColIndex As Integer
Set TargetRange = TargetRange.Cells(1, 1)
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DBFullName & ";"
Set Rs = New ADODB.Recordset
Dim Cd, Luc, Momen As Double
If Chocolumnn.op1.Value = True Then
Cco = 0
Call Delete_All
Else
Cco = Dem() - 1
End If
With Rs
.Open "SELECT [Column Forces].column,[Frame Assignments Summary].AnalysisSect,[Column Forces].loc,[Column Forces].story,[Column Forces].load,[Frame Assignments Summary].length,[Frame Section Properties].depth,[Frame Section Properties].widthtop,[Column Forces].p,[Column Forces].m2,[Column Forces].m3,[Column Forces].v2,[Column Forces].v3,[Control Parameters].CurrUnits FROM [Column Forces],[Frame Assignments Summary],[Frame Section Properties],[Control Parameters] WHERE [Column Forces].column = [Frame Assignments Summary].line and [Column Forces].story=[Frame Assignments Summary].story and [Frame Assignments Summary].AnalysisSect=[Frame Section Properties].SectionName", cn, , , adCmdText
.MoveFirst
Cells(13, 20).Value = .Fields(13).Value
Cd = Sheets("Data").Cells(5, 18).Value
Luc = Sheets("Data").Cells(5, 15).Value
Momen = Sheets("Data").Cells(5, 16).Value
i = 1
i = i + Cco
Range("A18").Select
Do
Range("A17:T17").Copy TargetRange.Offset(i, 0)
TargetRange.Offset(i, 0).Activate
TargetRange.Offset(i, 0).Value = i
TargetRange.Offset(i, 1).Value = .Fields(0).Value
TargetRange.Offset(i, 2).Value = .Fields(1).Value
TargetRange.Offset(i, 3).Value = .Fields(2).Value
TargetRange.Offset(i, 4).Value = .Fields(3).Value
TargetRange.Offset(i, 5).Value = .Fields(4).Value
TargetRange.Offset(i, 6).Value = Math.Round(Math.Abs(.Fields(6).Value) * Cd, 5)
TargetRange.Offset(i, 7).Value = Math.Round(Math.Abs(.Fields(7).Value) * Cd, 5)
'TargetRange.Offset(I, 8).Value = Cells(29, 11).Value
TargetRange.Offset(i, 9).Value = Math.Round(Math.Abs(.Fields(5).Value) * Cd, 5)
TargetRange.Offset(i, 10).Value = Math.Abs(.Fields(8).Value) * Luc
TargetRange.Offset(i, 11).Value = Math.Abs(.Fields(9).Value) * Momen
TargetRange.Offset(i, 12).Value = Math.Abs(.Fields(10).Value) * Momen
TargetRange.Offset(i, 13).Value = Math.Abs(.Fields(11).Value) * Luc
TargetRange.Offset(i, 14).Value = Math.Abs(.Fields(12).Value) * Luc
.MoveNext
i = i + 1
Loop Until .EOF
Range("A18").Select
End With
Rs.Close
Set Rs = Nothing
cn.Close
Set cn = Nothing
End Sub
Function Dem()
Dim jj
Range("A17").Select
jj = 0
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
jj = jj + 1
Loop
Dem = jj
Range("A18").Select
End FunctionPrivate Sub ComboBox1_Change()
ActiveCell = ComboBox1.Column(0)
ActiveCell.Offset(0, 1) = ComboBox1.Column(1)
ActiveCell.Offset(0, 2) = ComboBox1.Column(2)
End SubPrivate Sub ComboBox1_Change()
ActiveCell = ComboBox1.Column(0)
ActiveCell.Offset(0, 1) = ComboBox1.Column(1)
ActiveCell.Offset(0, 2) = ComboBox1.Column(2)
End Sub
Sub Worksheet_Selectionchange(ByVal target As Range)
With ComboBox1
On Error Resume Next
If target.Column = 3 Then
.Visible = True
.Top = target.Top
.Height = target.Height
.Left = target.Left
.Width = target.Width
.LinkedCell = target
ElseIf Application.CutCopyMode = False Then
.Visible = False
End If
End With
End SubMình hiểu là người dùng code For next
Đây là code của anh quanghai1969 thì phải?
1. TD là cái tên mà khi người vẽ cái userform đã gán cho nó. Muốn thay đổi tên này thì vào properties của Form
Ai dời qua đây làm kiếm muốn chết,
Và tôi có thử thêm cái này thay đoạn màu đỏ thành
nữa cũng chưa được. Tôi sai chổ nào bạn giải thích dùm. Cảm ơn bạn.
Ai dời qua đây làm kiếm muốn chết,
Cho hỏi thêm chút nhé bạn quanghai1969. VD tôi muốn cho code lập lại từ 1 đến 5 tại ô A1. Tôi có viết thử như thế này sao code chưa chạy được
Và tôi có thử thêm cái này thay đoạn màu đỏ thành nữa cũng chưa được. Tôi sai chổ nào bạn giải thích dùm. Cảm ơn bạn.
Biết là ham học là rất tôt nhưng nên học từ từ. "Biết cầm dao thì hãy nghĩ tới thái thức ăn". Bạn nên học từ từ. tôi thấy cơ bản của bản còn kém lắm! Cứ nghiên cứu thật kĩ cái cơ bản như For ..next chẳng hạn.Ai dời qua đây làm kiếm muốn chết,
Cho hỏi thêm chút nhé bạn quanghai1969. VD tôi muốn cho code lập lại từ 1 đến 5 tại ô A1. Tôi có viết thử như thế này sao code chưa chạy được
Và tôi có thử thêm cái này thay đoạn màu đỏ thành nữa cũng chưa được. Tôi sai chổ nào bạn giải thích dùm. Cảm ơn bạn.
Dẫu sao cũng cảm ơn bạn, Bạn nói gì vậy không biết thì hỏi là chuyện của người hỏi, trả lời hay không là chuyện của các bạn. Tôi mới tập mò mò. Thực ra tôi cũng có viết như thế này
Cho nên tôi mới thử viết cho 1 ô thử.
Bạn chẳng đưa cái file lên gì cả, tôi nhắm mắt làm bừa cho bạn luôn!
Sub NhapCongThuc()
Dim ipt
ipt = InputBox("Must be greater than 9", "Input row number")
ipt = Fix(Val(ipt))
If ipt > 9 Then
Range("A10:C1000, L10:N1000").ClearContents
Range("A9:C9").AutoFill Range("A9:C" & ipt), xlFillValues
Range("L9:N9").AutoFill Range("L9:N" & ipt), xlFillValues
With Range("A" & ipt + 1)
.Formula = "=COUNTA(" & Range("A9:A" & ipt).Address(0, 0) & ")"
.AutoFill Range("A" & ipt + 1 & ":C" & ipt + 1), xlFillValues
End With
With Range("L" & ipt + 1)
.Formula = "=COUNTA(" & Range("L9:L" & ipt).Address(0, 0) & ")"
.AutoFill Range("L" & ipt + 1 & ":N" & ipt + 1), xlFillValues
End With
Else
MsgBox "It's not done!"
End If
End SubVậy viết đi, chứ tui viết chỉ có như lày thui.
Sub NhapCongThuc()
MsgBox "Xong!"
End SubPrivate Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C3:C100]) Is Nothing Then
With Target.Offset(-1)
.Offset(, -2).Resize(2, 2).FillDown
.Offset(, 5).Resize(2).FillDown
End With
End If
End SubĐây là thủ tục về sự kiện của sheet, đặt macro này vào trong module của sheet đó, mọi thay đổi tại cột C (C3:C100) đều làm cho sự kiện thực thi.
Private Sub Worksheet_Change(ByVal Target As Range)
With Sheet4.Range("TenCT")
.Range("$A$2:$A$" & Range("$A$65000").End(xlUp).Row).Name = "TenCT"
End With
With Sheet4.Range("TenHH")
.Range("$C$2:$C$" & Range("$C$65000").End(xlUp).Row).Name = "TenHH"
End With
End SubBạn thử sửa lại thành:
Private Sub Worksheet_Change(ByVal Target As Range)
With Sheets("Sheet4")
.Range("$A$2:$A$" & Range("$A$65000").End(xlUp).Row).Name = "TenCT"
.Range("$C$2:$C$" & Range("$C$65000").End(xlUp).Row).Name = "TenHH"
End With
End SubPrivate Sub Worksheet_Change(ByVal Target As Range)
With Sheet4
.Range([A2], [A65536].End(3)).Name = "TenCT"
.Range([C2], [C65536].End(3)).Name = "TenHH"
End With
End SubEm lại trả lời trước khi tác giả upload file.
Bây giờ bạn gửi cái file thực của bạn lên đây đi, rồi yêu cầu gì nói rõ trong đó sẽ dễ dàng thực hiện hơn.
Public Sub chuyendulieu()
Dim Rng As Range, Tem1 As Double, Tem2 As Double, Cll As Range, R As Long, Vung As Range, I As Long
With Sheets("baocao")
Set Rng = .Range(.[C11], .[C65000].End(xlUp))
For Each Cll In Rng
R = Cll.Row
If Cll.Font.Bold = False Then
Tem1 = .Cells(R, "N").Value: Tem2 = .Cells(R, "O").Value
.Cells(R, "F") = Tem1: .Cells(R, "G") = Tem2
End If
Next
End With
Set Rng = Nothing
With Sheets("TonghopQI")
Set Rng = .Range(.[e9], .[e65000].End(xlUp))
On Error Resume Next
For Each Cll In Rng
If Cll.Font.Bold = False Then Cll.Value = Cll.Offset(0, -1).Value
Next Cll
End With
Set Rng = Nothing
With Sheets("QuyI")
On Error Resume Next
.Range(.[p8], .[p5000].End(xlUp)).SpecialCells(2).ClearContents
Set Vung = .Range(.[p8], .[p5000].End(xlUp))
For I = 1 To Vung.Rows.Count
If Vung(I) = "" And Vung(I).Offset(, -1) 0 Then Vung(I) = Vung(I).Offset(, -1)
Next
End With
End SubBạn muốn người khác xem code thực thi như thế nào thì làm ơn gửi một cái file đó lên người ta mới có cơ sở để sửa code hoặc đưa ra hướng khác, chứ đưa lên thế có thánh mới hiểu sẽ thực hiện như thế nào bạn ơi!
Mình đính kèm file, Sheet "CD SPS" tổng hợp số từ sheet "NKC" nên khi dữ liệu ở NKC nhiều thì mỗi lần nó chuyển số Cuối kỳ từ CD SPS thành Đầu kỳ của CD SPS chạy rất chậm
Trước khi tôi có hướng xử lý, cho tôi hỏi đoạn code này bạn dùng để làm gì?
With Sheets("LCTT")
.Range(.Range("AD8"), .Range("AD5000").End(xlUp)).SpecialCells(2).ClearContents
Set Vung = .Range(.Range("AD8"), .Range("AD5000").End(xlUp))
For I = 1 To Vung.Rows.Count
If Vung(I) = "" And Vung(I).Offset(, -1) <> 0 Then Vung(I) = Vung(I).Offset(, -1)
Next
End WithSub chuyendulieu()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim R As Long, I As Long
Dim Cll As Range, Rng As Range, Vung As Range
R = Range("TongCong").Row - 1
Set Rng = Sheets("CD SPS").Range("C11:C" & R)
For Each Cll In Rng
If Cll.Font.Bold = False Then
Cll.Offset(, 3) = Cll.Offset(, 11)
Cll.Offset(, 4) = Cll.Offset(, 12)
End If
Next
R = Range("LaiCoBan").Row
Set Rng = Sheets("KQKD").Range("E10:E" & R)
For Each Cll In Rng
If Cll.Font.Bold = False Then
Cll.Value = Cll.Offset(0, -1).Value
End If
Next
On Error Resume Next
[COLOR=#0000ff] ''Cai nay thi de nguyen vi khong biet sua lam sao![/COLOR]
With Sheets("LCTT")
.Range(.Range("AD8"), .Range("AD65536").End(xlUp)).SpecialCells(2).ClearContents
Set Vung = .Range(.Range("AD8"), .Range("AD65536").End(xlUp))
For I = 1 To Vung.Rows.Count
If Vung(I) = "" And Vung(I).Offset(, -1) <> 0 Then Vung(I) = Vung(I).Offset(, -1)
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End SubAnh em trên diễn đàn giúp nhau không vụ lợi, nhưng anh em gặp nhau cũng thật sự là một điều tốt đẹp. Tôi ở TPHCM, bữa nào muốn thì tôi hú hí anh em cùng ra cafe.
With Range("A" With Range("A" & ipt + 1)
.AutoFill Range("A" & ipt + 1 & ":B" & ipt + 1), xlFillValues
End With
With Range("P" & ipt + 1)
.AutoFill Range("P" & ipt + 1 & ":R" & ipt + 1), xlFillValues
End With
)
Bạn bỏ 2 dòng đó đi là được rồi.Em ko biết
- cái đầu: copy công thức cột A từ dòng em nhập vào nên em thay chữ cái tương ứng với cột
- cái thứ 2 thì Copy từ P tới R nên cái đầu em cho là A đến A ạ
Sub CopyCongThucCDSPS()
Dim ipt
[COLOR=#0000ff]''Xac dinh dong cuoi cua bang, lam so hang mac dinh:[/COLOR]
ipt = Range("[COLOR=#ff0000]TongCong[/COLOR]").Row - 1
ipt = InputBox("Luu y! So dong phai tu 10 tro di", "Nhap so dong can copy den", ipt)
ipt = Fix(Val(ipt))
If ipt > 10 Then
With Sheets("CD SPS")
[COLOR=#0000ff] ''Copy cong thuc tu o A10:[/COLOR]
.Range("A10").AutoFill .Range("A10:A" & ipt), xlFillValues
[COLOR=#0000ff]''Copy cong thuc tu P10:R10:[/COLOR]
.Range("P10:R10").AutoFill .Range("P10:R" & ipt), xlFillValues
End With
Else
MsgBox "It's not done!"
End If
End SubVới bài trên, bạn cũng không cần cái InputBox làm gì, bỏ nó luôn:
Sub CopyCongThucCDSPS()
Dim r As Long
[COLOR=#0000ff] ''Xac dinh so dong cuoi cua bang:[/COLOR]
r = Range("[COLOR=#ff0000]TongCong[/COLOR]").Row - 1
With Sheets("CD SPS")
[COLOR=#0000ff] ''Copy cong thuc tu o A10:[/COLOR]
.Range("A10").AutoFill .Range("A10:A" & r), xlFillValues
[COLOR=#0000ff] ''Copy cong thuc tu P10:R10:[/COLOR]
.Range("P10:R10").AutoFill .Range("P10:R" & r), xlFillValues
End With
End SubSố điện thoại ở tại bài đó rồi còn gì! Nhìn kỹ xem!nhà em thì ở Q5. Làm ở Q3 nhưng hứng lên là wa cafe luôn, anh cho số đt đi, nếu ổn mai em wa cafe luôn
Tạm sửa thế này
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
ActiveWindow.FreezePanes = False
Dim Dangchon As Range
Set Dangchon = ActiveCell
Select Case ActiveCell.Row
Case Is < 21
Range("2:2").EntireRow.Select
ActiveWindow.FreezePanes = True
Case Is < 41
Range("22:22").EntireRow.Select
ActiveWindow.FreezePanes = True
Case Is < 61
Range("42:42").EntireRow.Select
ActiveWindow.FreezePanes = True
Dangchon.Select
Case Else
Range("62:62").EntireRow.Select
ActiveWindow.FreezePanes = True
End Select
Application.EnableEvents = True
End SubOption Explicit
Public Sub ChamCong()
On Error Resume Next
Dim sArr(), dArr(), I As Long, J As Long, K As Long, Col As Long, Tem As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("DATA")
sArr = .Range(.[A2], .[A65536].End(xlUp)).Resize(, 5).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 33)
For I = 1 To UBound(sArr, 1)
Tem = sArr(I, 1)
Col = Right(sArr(I, 3), 2) * 2 + 2
If Val(Left(sArr(I, 4), 2)) > 12 Then Col = Col + 1
[U]If Not Dic.Exists(Tem) Then[/U]
K = K + 1
Dic.Add Tem, K
dArr(K, 1) = K
dArr(K, 2) = sArr(I, 1)
dArr(K, 3) = sArr(I, 2)
End If
dArr(Dic.Item(Tem), Col) = sArr(I, 4)
Next I
Application.ScreenUpdating = False
With Sheets("ChamCong")
.[A5:A1000].Resize(, 33).ClearContents
.[A5:A1000].Resize(, 33).Borders.LineStyle = xlNone
If K Then
.[A5].Resize(K, 33) = dArr
.[A5].Resize(K, 33).Borders.LineStyle = xlContinuous
End If
End With
Application.ScreenUpdating = True
Set Dic = Nothing
End Sub
Sub Capnhat()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Cell As Range
Dim Cll As Range
For Each Cell In Sheet5.Range("D2:D" & [d50000].End(xlUp).Row)
If Left(Cell, 2) = "PX" Then
If Cell.Offset(0, -3).Value <> "x" Then
For Each Cll In Sheets(Cell.Offset(0, 16).Value).Range("c7:c" & [c50000].End(xlUp).Row)
If Cell.Offset(0, 6).Value = Cll.Value Is Nothing Then
Sheets(Cell.Offset(0, 16).Value).[c50000].End(xlUp).Offset(1, 0).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Sheets(Cell.Offset(0, 16).Value).[c7].End(xlDown).Offset(1, 0).Value = Cell.Offset(, 6)
Sheets(Cell.Offset(0, 16).Value).[c7].End(xlDown).Offset(1, 1).Value = Cell.Offset(, 7)
Sheets(Cell.Offset(0, 16).Value).Range("C" & [c7].End(xlDown)(1, 0).Row & ":F" & [c7].End(xlDown)(1, 0).Row).Value = Sheet5.Range(Cell.Offset(, 6), Cell.Offset(, 9))
Cell.Offset(0, -3).Value = "x"
End If
Next
End If
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Các bác giải thích vì sao đoạn code này của em không hoạt động không ak? Excel treo luôn akMã:Sub Capnhat() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ....... Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub
Em cảm ơn các bác ạ
For Each Cell In Sheet5.Range("D2:D" & [d50000].End(xlUp).Row)
...
For Each Cll In Sheets(Cell.Offset(0, 16).Value).Range("c7:c" & [c50000].End(xlUp).Row)
...
Sheets(Cell.Offset(0, 16).Value).Range("C" & [c7].End(xlDown)(1, 0).Row &If Cell.Offset(0, 6).Value = Cll.Value [COLOR="#FF0000"]Is Nothing[/COLOR] Thenhttps://www.dropbox.com/s/fk93qhhy20y3zok/B%C3%A1o%20c%C3%A1o%20stock%20nh%C3%A0%20m%C3%A1y%207.2014%20-%20Copy.xlsmcode của bạn muốn cải thiện tốc độ thì có thể phải dùng mảng hoặc phương thức Find hoặc Union khi chèn Row ...Cái đỏ đỏ là nếu cái ở bên sheet bên này bằng với giá trị bên kia thì sẽ không làm gì cả, còn nếu không thì sẽ thêm 1 dòng và copy mọt số dữ liệu bên sheet kia sang đó bác
Em đính kèm file lên cho mọi người dễ hình dung ak
HTML:https://www.dropbox.com/s/fk93qhhy20y3zok/B%C3%A1o%20c%C3%A1o%20stock%20nh%C3%A0%20m%C3%A1y%207.2014%20-%20Copy.xlsm
code của bạn muốn cải thiện tốc độ thì có thể phải dùng mảng hoặc phương thức Find hoặc Union khi chèn Row ...
Không có file thì khó cho các thành viên bắt bệnh bạn ạh
- mới thử phương thức Find thay thế cho 1 vòng lặp mà đã thấy ...
Sub Capnhat()
Dim CurSheet As Worksheet, ws As Worksheet
Dim Cell As Range
Dim iRow1 As Long, iRow2 As Long
Dim Rng As Range, rngFound As Range
'chua cai` Unhide Row cho cac sheet.
Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
Set CurSheet = Sheets("update")
For Each Cell In CurSheet.Range("D2:D" & Range("D65000").End(xlUp).Row)
If CurSheet.Range("T" & Cell.Row) = "EXT" Then
If Left(Cell, 2) = "PX" And Cell.Offset(0, -3) <> "x" Then
iRow1 = Cell.Row
On Error Resume Next 'neu ko co' Ten sheet
Set ws = Sheets(CurSheet.Range("T" & iRow1).Value)
Set Rng = ws.Range("C7:C65000")
Set rngFound = Rng.Find(CurSheet.Range("J" & iRow1).Value, , xlValues, xlWhole) 'xlWhole--> tim` chinh' xac
'---------
If rngFound Is Nothing Then 'neu ko tim` thay'
iRow2 = ws.Range("C65000").End(xlUp).Offset(1, 0).Row
ws.Range("C" & iRow2).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ws.Range("C" & iRow2).Resize(, 4).Value = CurSheet.Range("J" & iRow1).Resize(, 4).Value
Cell.Offset(0, -3) = "x"
End If
End If
End If
Next
'Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "xong"
End Sub
