Anh tin em!Anh tin chị ấy thì có nước đổ thóc giống ra mà ăn
Em nhảy vào chắc ế nguyên tập quá!Chời ơi! topic đang "ế" có anh kiệt nhảy vào ra tay tương trợ, bạn đành lòng ngăn cản để "ế" tiếp à.
Cảm ơn Thầy đã giúp.
Dim TabTracker As New TabBack_Class
Sub TabBack_Run()
'PURPOSE: Initiate Tab tracking and shortcut key trigger
‘SOURCE: www.TheSpreadsheetGuru.com
'Enable TabTracker class
Set TabTracker.AppEvent = Application
'Call ToggleBack macro when user keys alt + `
Application.OnKey “%`”, “ToggleBack”
End Sub
Sub ToggleBack()
'PURPOSE: Go Back to Previous Worksheet
‘SOURCE: www.TheSpreadsheetGuru.com
With TabTracker
On Error Resume Next
Workbooks(.WorkbookReference).Worksheets(.SheetReference).Activate
On Error GoTo 0
End With
End SubPublic WithEvents AppEvent As Application
Public SheetReference As String
Public WorkbookReference As String
Private Sub AppEvent_SheetDeactivate(ByVal Sh As Object)
'PURPOSE: Store active worksheet information before leaving it
'SOURCE: www.TheSpreadsheetGuru.comWorkbookReference = Sh.Parent.Name
SheetReference = Sh.Name
End Sub
Private Sub AppEvent_WorkbookDeactivate(ByVal Wb As Workbook)
'PURPOSE: Store active worksheet information before closing workbook
'SOURCE: www.TheSpreadsheetGuru.com
WorkbookReference = Wb.Name
SheetReference = Wb.ActiveSheet.Name
End Sub
Cho xin 500 bức hình để được thỏa con mắt về cái lỗi lầm kia.
1. Nhìn ký tự trước PURPOSE và trước SOURCE (ở mọi nơi) thì mắt thường thấy khác nhau. Nếu trước PURPOSE là dấu nháy đơn thì trước SOURCE không thể là dấu nháy đơn mà chỉ "nhìn giống" dấu nháy đơn. Sửa lại.
1. Em không hiểu ý này lắm nên em không biết trả lời thế nào.
Có gì mà không hiểu?
Ở Sub ShowSearch, thêm dòng sau vào sau dòng AssemblyArr = ...
ReDim Preserve AssemblyArr(1 To UBound(AssemblyArr, 1), 1 To 2)Thanks bác, mất một ngày tìm ko ra mà bác chỉ mất 30s đã ok.
Vì gán như cũ thì listbox kết quả chỉ có 1 cột, mà sau đó bạn muốn dùng 2 cột
Không phải khai báo lại thành mảng hai chiều mà là mở rộng mảng hai chiều. Mảng ban đầu của bạn cũng là mảng hai chiều nhưng kích thước chiều thứ hai là 1. Câu lệnh trên là mở rộng kích thước chiều thứ hai thành 2.
Thay đổi được, nếu bạn gán lại list() với mảng mớiTại e tưởng sau khi clear listbox rồi thì muốn gán mấy chiều vào cũng được, listbox sẽ nhận số chiều theo lệnh .list(...)
như vậy là listbox sẽ nhận số chiều của mảng gán lúc đầu, không thay đổi được à các bác?
Nếu bạn gán một mảng cho thuộc tính .List thì số cột là kích thước chiều thứ hai của mảng được gán. Nếu bạn dùng phương thức .Additem ngay từ đầu thì số cột là giá trị thuộc tính .ColumnCount.Tại e tưởng sau khi clear listbox rồi thì muốn gán mấy chiều vào cũng được, listbox sẽ nhận số chiều theo lệnh .list(...)
như vậy là listbox sẽ nhận kích thước của mảng gán lúc đầu, không thay đổi được à các bác?
Hay quá bác ndu96081631 ơi, không cần phải vòng lặp nào cả, Bác làm như nào vậy hả bác?
Anh ơi, người ta chưa biết và mới học thì mới mắc sai lầm, anh là người am hiểu nếu anh biết thì anh chỉ dẫn giúp cho người ta đi. Sao anh lại nói như vậy? @truongvu317
Tui chả phải là người am hiểu gì cả, nhưng tui nói thật. Cái thứ nhất phải có file, phải có dữ liệu, mô tả mã lỗi.... Không có thì chả khác nào đánh đố nhau.
Bác cho hỏi thêm một chút là em muốn hiện số dòng của listbox listcount vào một label mỗi khi số dòng của listbox thay đổi, em đã thử dùng sự kiện listbox change, listbox after update nhưng không hiệu quả.
Không có sự kiện có sẵn kiểu như vậy đâu. Số dòng của listbox thay đổi là do bạn thực hiện một lệnh nào đó, như vậy bạn muốn đếm thì đếm khi thực hiện lệnh đó là được.
Thanks bác nhiều, nhờ bác chỉ dẫn e đã gần hoàn thành được chương trình rồi. Tuy nhiên e đang còn một chỗ mắc cuối nhờ bác xem giúp.
Không biết có phải như vầy không
Sub CongCham()
Dim Rng, sArr, tArr, dArr, I As Long, J As Long, Col As Long, R As Long
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet9
Set Rng = .Range("E8:AI8")
sArr = .Range("B10", .Range("B" & Rows.Count).End(xlUp)).Resize(, 34).Value
End With
With Sheet3
tArr = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Resize(, 6).Value
End With
For I = 1 To UBound(tArr)
Dic.Item(CStr(tArr(I, 3))) = I
Next I
ReDim dArr(1 To UBound(sArr), 1 To 31)
For I = 1 To UBound(sArr)
R = Dic.Item(sArr(I, 1))
If R Then
For J = 1 To Rng.Columns.Count
If tArr(R, 1) = Rng(1, J) Then
Col = J: Exit For
End If
Next J
If Col Then dArr(I, Col) = tArr(R, 6)
Col = 0
End If
Next I
Sheet9.Range("E10:AI10").Resize(I - 1).ClearContents
Sheet9.Range("E10:AI10").Resize(I - 1) = dArr
End SubCảm ơn bạn đã giúp đỡ.
Bạn thử lại Code này
Public Sub CongCham()
Dim Rng, sArr, tArr, dArr, I As Long, J As Long, R As Long
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet9
Set Rng = .Range("E8:AI8")
sArr = .Range("B10", .Range("B" & Rows.Count).End(xlUp)).Resize(, 34).Value
End With
With Sheet3
tArr = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Resize(, 6).Value
End With
For I = 1 To UBound(tArr)
Dic.Item(CStr(tArr(I, 3))) = I
Next I
ReDim dArr(1 To UBound(sArr), 1 To 31)
For I = 1 To UBound(sArr)
R = Dic.Item(sArr(I, 1))
For J = 1 To Rng.Columns.Count
If R Then
If tArr(R, 1) = Rng(1, J) Then
dArr(I, J) = tArr(R, 6)
Else
dArr(I, J) = sArr(I, J + 3)
End If
Else
dArr(I, J) = sArr(I, J + 3)
End If
Next J
Next I
Sheet9.Range("E10:AI10").Resize(I - 1).ClearContents
Sheet9.Range("E10:AI10").Resize(I - 1) = dArr
Set Dic = Nothing
End SubCảm ơn bạn thật nhiều.
Bạn giúp mình tí nữa ạ. Mình thử 2 ngày nghỉ cho 1 mã nv nhưng code chỉ lấy ngày sau cùng.
Bạn thử xem
Public Sub CongCham()
Dim Rng, sArr, tArr, dArr, I As Long, J As Long
Dim Dic As Object, sKey As String, R As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet9
Set Rng = .Range("E8:AI8")
sArr = .Range("B10", .Range("B" & Rows.Count).End(xlUp)).Resize(, 34).Value
End With
With Sheet3
tArr = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Resize(, 6).Value
End With
For I = 1 To UBound(tArr)
sKey = tArr(I, 1) & "#" & tArr(I, 3)
Dic.Item(sKey) = I
Next I
ReDim dArr(1 To UBound(sArr), 1 To 31)
For I = 1 To UBound(sArr)
For J = 1 To Rng.Columns.Count
sKey = Rng(1, J) & "#" & sArr(I, 1)
R = Dic.Item(sKey)
If R Then
dArr(I, J) = tArr(R, 6)
Else
dArr(I, J) = sArr(I, J + 3)
End If
Next J
Next I
With Sheet9
.Range("E10:AI10").Resize(I - 1).ClearContents
.Range("E10:AI10").Resize(I - 1) = dArr
End WithCảm ơn bạn đã nhiệt tình giúp đỡ.
1/ Ở Topic kia tôi cũng đã góp ý cho bạn là nên nêu rỏ vấn đề cần làm rồi nhờ giúp, người giúp đập bỏ đi và có giải pháp khác rồi làm lại chỉ vài dòng code còn nhanh hơn là mò sửa cái cái Record Macro (sẽ không hiểu hết ý của bạn), nhưng bạn lại không nghe và đưa lên một đống code thừa thải.
Bạn nên tập thói quen nhận ý kiến đóng góp của các thành viên mới mong nhận được giải pháp tốt nhất.
Tôi chưa rành code và thiết kế cho lắm, mong bạn giúp, mới thàm gia. Xin cảm ơn.
Tôi thấy bác kia nói đúng đấy. Tôi cũng mới mò vba nên code viết còn rườm rà, nhưng nhìn code của bác thì choáng luôn.
Bạn sử dụng thử đoạn code này xem sao.
rivate Sub NHAP_Click()
Dim n As Integer
n = Application.WorksheetFunction.CountA(Sheet3.Range("B12:B18"))
With Sheet9.Range("A65000").End(xlUp)
.Offset(1).Resize(n) = Sheet3.[B3]
.Offset(1, 1).Resize(n) = Sheet3.[D3]
.Offset(1, 3).Resize(n) = Sheet3.[D5]
.Offset(1, 7).Resize(n, 3).Value = Sheet3.Range("B12").Resize(n, 3).Value
End With
End SubCảm ơn Bạn Giaiphap rất nhiều. code quá tuyệt mình vận dụng được rồi. Đa tạ
Em xin nhờ bạn giaiphap có thể viết giúp em đoạn code lọc số liệu từ sheet DATA NHAP sang sheet BANGKE với yêu cầu khi e gõ ngày thanh toán vào 1 ô cho sẳn ở sheet BANGKE thì excel tự lọc và điền vào các cột tương ứng và tách theo từng loại trợ giá trong sheet DATA NHAP. Anh có thể viết code và điền vài dữ liệu vào các cột trong sheet BANGKE cũng được em tự nghiên cứu và phát triển cho các cột kế tiếp. vì e muố phải đọc và hiểu code do e mới tập tành. mong A giúp đỡ. Chân thành cảm ơn A
Bạn phải mô tả chi tiết hơn, tôi nhìn vào không biết lấy dữ liệu cột nào để điền vào cột trọng lượng, cột tổng giá thanh toán tính bằng cách nào, cột M để trống là sao? Còn điều kiện lọc là lọc ngày thanh toán hay ngày mua...
Chào bạn giaiphap
Chào bạn
Tôi sửa code để thục hiện ý 2 và 3 của bạn, còn ý 1 thì đọc hoài vẫn chưa hiểu ô C7 nhập vào để làm việc gì trong điều kiện lọc của bạn, vã lại nơi TT là cột nào sao tôi tìm không thấy.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Arr(), dArr(), iCol(), i As Integer, k As Integer, Ngay, j As Integer, Rng As Range, ary
If Target.Address = "$A$3" Then
Arr = Sheet9.Range("A2:O" & Sheet9.Range("A65000").End(xlUp).Row).Value
ReDim dArr(1 To UBound(Arr, 1), 1 To 13)
Ngay = Target.Value
iCol = Array(9, 4, 5, 6, 7, 1, 12, 1, 1, 11, 13, 1, 14)
For i = LBound(Arr, 1) To UBound(Arr, 1)
If Ngay >= Arr(i, 2) Then
k = k + 1
For j = 0 To 12
If iCol(j) <> 1 Then dArr(k, j + 1) = Arr(i, iCol(j))
Next j
End If
Next i
Sheet25.Range("A14:M" & (Sheet25.Range("A65000").End(xlUp).Row) + 5).Clear
If k <> 0 Then
With Sheet25
.Range("A14").Resize(k, 13).Value = dArr
.Sort.SortFields.Clear
.Range("A14:M" & (k + 13)).Sort Key1:=.Range("M14:M" & (k + 13)), order1:=xlDescending, Header:=xlNo
j = .Range("A65000").End(xlUp).Row
For i = j To 14 Step -1
If .Range("M" & i) <> .Range("M" & (i - 1)) Then
.Rows(i & ":" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("A" & i).Value = "T" & ChrW(7893) & "ng h" & ChrW(7897) & " bán thý" & ChrW(7901) & "ng xuyên ðý" & ChrW(7907) & _
"c tr" & ChrW(7907) & " giá (+" & .Range("M" & (i + 1)).Value & " ð" & ChrW(7891) & "ng/TSC)"
.Range("A" & i).Font.Bold = True
End If
Next i
.Range("M14:M" & .Range("A65000").End(xlUp).Row).ClearContents
.Range("A14:M" & .Range("A65000").End(xlUp).Row).Borders.LineStyle = 1
With .Range("A65000").End(xlUp).Offset(1)
.Value = "B" & ChrW(7857) & "ng ch" & ChrW(7919) & ":"
.Offset(2, 1).Value = "Ngý" & ChrW(7901) & "i l" & ChrW(7863) & "p b" & ChrW(7843) & "ng kê"
.Offset(2, 1).Font.Bold = True
.Offset(1, 11).Value = "Ngày ... tháng .... nãm ....."
.Offset(2, 11).Value = "Giám ð" & ChrW(7889) & "c doanh nghi" & ChrW(7879) & "p"
.Offset(2, 11).Font.Bold = True
.Offset(3, 1).Value = "(K" & ChrW(253) & ", ghi r" & ChrW(245) & " h" & ChrW(7885) & " tên)"
.Offset(3, 11).Value = "(K" & ChrW(253) & " tên, ðóng d" & ChrW(7845) & "u)"
.Offset(2, 1).Resize(2).HorizontalAlignment = xlCenter
.Offset(1, 11).Resize(3).HorizontalAlignment = xlCenter
End With
End With
End If
End If
End SubTrước tiên xin chân thành cảm ơn bạn đã giúp đỡ.
Chào bạn
Dạ đúng! chỉ lọc kho nào dc nhập thôi ạ. à chổ Giám đốc mình chưa nhập nhưng do chưa hiểu nên hỏi để hiểu ý nghĩa thôi ạ. Thank Bạn
Nếu vậy thì sửa code thế này nhé. Còn việc gõ trực tiếp tên tiếng việt theo bảng mã Unicode trong code là không thể, chính vì vậy những ký tự không dấu thì gõ trực tiếp được còn những ký tự chứa mã Unicode thì bắt buộc phải dùng hàm ChrW để chuyển.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Arr(), dArr(), iCol(), i As Integer, k As Integer, Ngay, j As Integer, Rng As Range, Kho As String
If Target.Address = "$A$3" Then
Arr = Sheet9.Range("A2:O" & Sheet9.Range("A65000").End(xlUp).Row).Value
ReDim dArr(1 To UBound(Arr, 1), 1 To 13)
Ngay = Target.Value: Kho = Sheet25.[C7]
iCol = Array(9, 4, 5, 6, 7, 1, 12, 1, 1, 11, 13, 1, 14)
For i = LBound(Arr, 1) To UBound(Arr, 1)
If (Ngay >= Arr(i, 2)) And (Kho = Arr(i, 8)) Then
k = k + 1
For j = 0 To 12
If iCol(j) <> 1 Then dArr(k, j + 1) = Arr(i, iCol(j))
Next j
End If
Next i
Sheet25.Range("A14:M" & (Sheet25.Range("A65000").End(xlUp).Row) + 5).Clear
If k <> 0 Then
With Sheet25
.Range("A14").Resize(k, 13).Value = dArr
.Sort.SortFields.Clear
.Range("A14:M" & (k + 13)).Sort Key1:=.Range("M14:M" & (k + 13)), order1:=xlDescending, Header:=xlNo
j = .Range("A65000").End(xlUp).Row
For i = j To 14 Step -1
If .Range("M" & i) <> .Range("M" & (i - 1)) Then
.Rows(i & ":" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("A" & i).Value = "T" & ChrW(7893) & "ng h" & ChrW(7897) & " bán thý" & ChrW(7901) & "ng xuyên ðý" & ChrW(7907) & _
"c tr" & ChrW(7907) & " giá (+" & .Range("M" & (i + 1)).Value & " ð" & ChrW(7891) & "ng/TSC)"
.Range("A" & i).Font.Bold = True
End If
Next i
.Range("M14:M" & .Range("A65000").End(xlUp).Row).ClearContents
.Range("A14:M" & .Range("A65000").End(xlUp).Row).Borders.LineStyle = 1
With .Range("A65000").End(xlUp).Offset(1)
.Value = "B" & ChrW(7857) & "ng ch" & ChrW(7919) & ":"
.Offset(2, 1).Value = "Ngý" & ChrW(7901) & "i l" & ChrW(7863) & "p b" & ChrW(7843) & "ng kê"
.Offset(2, 1).Font.Bold = True
.Offset(1, 11).Value = "Ngày ... tháng .... nãm ....."
.Offset(2, 11).Value = "Giám ð" & ChrW(7889) & "c doanh nghi" & ChrW(7879) & "p"
.Offset(2, 11).Font.Bold = True
.Offset(3, 1).Value = "(K" & ChrW(253) & ", ghi r" & ChrW(245) & " h" & ChrW(7885) & " tên)"
.Offset(3, 11).Value = "(K" & ChrW(253) & " tên, ðóng d" & ChrW(7845) & "u)"
.Offset(2, 1).Resize(2).HorizontalAlignment = xlCenter
.Offset(1, 11).Resize(3).HorizontalAlignment = xlCenter
End With
End With
End If
End If
End SubSub abc()
With Sheets("TMV.Map")
.Range("A2:B9").Copy Sheets("Vietmap").Range("A2")
.Range("E2:E9").Copy Sheets("Vietmap").Range("G2")
End With
End SubDạ e hiểu rồi Để em nhập xong xem thế nào.à mà cái button nhập khi nhấn 1 lần tự mờ a xem giúp code dùm e với nha. Cảm ơn A nhiều
Cho mình hỏi vấn đề này nữa ạ
Thử chạy code này:
Public Sub Update_CSDL()
Dim sArr(), tArr(), I As Long, J As Long, Rws As Long, R As Long, Txt As String
tArr = Sheets("Thongtin").Range("A2", Sheets("Thongtin").Range("A2").End(xlDown)).Resize(, 45).Value
With CreateObject("Scripting.Dictionary")
For I = 1 To UBound(tArr)
.Item(tArr(I, 1) & "#" & tArr(I, 2)) = I
Next I
sArr = Sheets("CSDL").Range("A2", Sheets("CSDL").Range("A2").End(xlDown)).Resize(, 45).Value
R = UBound(sArr)
For I = 1 To R
Txt = sArr(I, 1) & "#" & sArr(I, 2)
If .Exists(Txt) Then
Rws = .Item(Txt)
For J = 13 To 32
sArr(I, J) = tArr(Rws, J)
Next J
End If
Next I
End With
Sheets("CSDL").Range("A2").Resize(R, 45) = sArr
End SubCảm ơn bạn.
Cảm ơn bác. Nhưng các cột từ AG đến AS không cập nhập dữ liệu được. Bác kiểm tra lại hộ em với.
dạ rồi tối e gửi cho ạ. Cảm ơn rất nhiều
=INDEX(LINEST(A2:A33,B2:E33,,TRUE),3,1)
dạ chào Anh
Dạ cảm ơn Anh nhiều quá. quá tuyệt anh ơi. thế là ok rồi.
hix. Em nguyễn cứu code trong diễn dàn cả tháng rồi mà ko tìm thấy code mình cần nên mới mạo muội nhờ mấy bác!!! Nhưng mà tình hình này chắc phải cứu nhâm njawx thôi
Bạn đưa cái file mẫu lên đi,
Để cái thiện tốc độ thì sửa công thức đi, đừng có dùng tham chiếu kiểu A:A, làm vậy sẽ rất chậm do nó phải tính toán, thay bằng A1:A30000 chẳng hạn.
File của em đây bác nhưng mà là file chạy bằng hàm ko phải là fife chạy bằng code.
File gốc của em thì chỉ có 1 đòng công thức dạng text thôi. Mỗi lần em sử dụng hàm em chỉnh số dòng đúng bằng số dòng của FILE giá rồi mới kéo công thức xuống nhưng giờ FILE giá cũng hơn 60000 dòng rồi nên chạy rất chậm ạ
Dạ tại em đặt cho giống với cái FILE lấy giá trong Cty ạ. Ở bài trước em nói Password mở file là 11 và Password ko cho sửa nội dung là 1.
Em đọc khá nhiều bài trong diễn đàn nên em nói hết ý của em ở bài #1797 và nhờ các bác giúp đỡ chứ sợ công sức các bác bỏ ra giúp em mà này thêm cái này mai sửa cái kia em cũng ngại ạ
dạ cảm ơn A nhiều.
kính gửi giaiphap
Cảm ơn Bác! E, đang gà quá, em làm được rồi. Bác có giáo trình nào hay cho em học hỏi với.
Dạ ô L32 theo file mẫu là hàm sum tổng công cho các ô của từng loại trợ giá. nếu ngày nào đó thanh toán nhiều thì lọc thì là ô
Code cho file ở #1815.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Arr(), dArr(), iCol1(), i As Integer, k As Integer, Ngay, j As Integer, Rng As Range, KHO As String
If Target.Address = "$A$3" Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Arr = Sheet9.Range("A2:O" & Sheet9.Range("A65000").End(xlUp).Row).Value
ReDim dArr(1 To UBound(Arr, 1), 1 To 13)
Ngay = Target.Value: KHO = Sheet25.[$C$7]
iCol = Array(9, 4, 5, 6, 7, 1, 11, 1, 1, 10, 12, 1, 13)
For i = LBound(Arr, 1) To UBound(Arr, 1)
If (Ngay >= Arr(i, 2)) And (KHO = Arr(i, 8)) Then
k = k + 1
For j = 0 To 12
If iCol(j) <> 1 Then dArr(k, j + 1) = Arr(i, iCol(j))
Next j
End If
Next i
Sheet25.Range("A14:M" & (Sheet25.Range("A65000").End(xlUp).Row) + 5).Clear
If k <> 0 Then
With Sheet25
.Range("A14").Resize(k, 13).Value = dArr
.Sort.SortFields.Clear
.Range("A14:M" & (k + 13)).Sort Key1:=.Range("M14:M" & (k + 13)), order1:=xlDescending, Header:=xlNo
.Range("L14").FormulaR1C1 = "=RC[-5]*RC[-2]*(RC[-1]+RC[1])"
.Range("L14").AutoFill Destination:=.Range("L14:L" & (k + 13)), Type:=xlFillDefault
.Range("L14:L" & (k + 13)).Value = .Range("L14:L" & (k + 13)).Value
j = .Range("A65000").End(xlUp).Row
For i = j To 13 Step -1
If .Range("M" & i) <> .Range("M" & (i - 1)) Then
.Rows(i & ":" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
.Range("B" & i).Value = "Toång hoä baùn thöôøng xuyeân ñöôïc trôï giaù +" & .Range("M" & (i + 1)).Value & " ñoàng/TSC"
.Range("B" & i).Font.Name = "VNI-Times"
.Range("B" & i & ":L" & i).Font.Bold = True
End If
Next i
For Each Rng In .Range("L14:L" & .Range("L65000").End(xlUp).Row).SpecialCells(2).Areas
.Range("J" & (Rng.Row - 1)).Formula = "=sum(" & Replace(Rng.Offset(, -2).Address, "$", "") & ")"
.Range("L" & (Rng.Row - 1)).Formula = "=sum(" & Replace(Rng.Address, "$", "") & ")"
Next
.Range("M14:M" & .Range("A65000").End(xlUp).Row).ClearContents
With .Range("A65000").End(xlUp)
.Offset(1).Value = "Toång giaù trò haøng hoùa ñöôïc mua vaøo "
.Offset(1).Resize(, 13).Font.Name = "VNI-Times"
.Offset(1).Resize(, 13).Font.Bold = True
.Offset(1).Resize(, 13).Font.Color = -16776961
.Offset(1).Resize(, 6).HorizontalAlignment = xlCenter
.Offset(1).Resize(, 6).Merge
.Offset(1, 9).Formula = "=SUMIF(R14C3:R[-1]C3,"""",R14C10:R[-1]C10)"
.Offset(1, 11).Formula = "=SUMIF(R14C3:R[-1]C3,"""",R14C12:R[-1]C12)"
End With
.Range("A14:M" & .Range("A65000").End(xlUp).Row).Borders.LineStyle = 1
With .Range("A65000").End(xlUp).Offset(1)
.Value = "Baèng chöõ:"
.Offset(, 1).Formula = "=HamDocTV(" & .Offset(-1, 11).Address & ")" 'Sua ham doc tieng viet cho nay
.Offset(2, 1).Value = "Ngöôøi laäp baûng keâ"
.Offset(2, 1).Font.Bold = True
.Offset(1, 11).Value = "Ngaøy ... thaùng .... naêm ......"
.Offset(2, 11).Value = "Giaùm ñoác danh nghieäp"
.Offset(2, 11).Font.Bold = True
.Offset(3, 1).Value = "(Kyù vaø ghi roõ hoï teân)"
.Offset(3, 11).Value = "(Kyù teân, ñoùng daáu)"
.Offset(2, 1).Resize(2).HorizontalAlignment = xlCenter
.Offset(1, 11).Resize(3).HorizontalAlignment = xlCenter
.Resize(5, 13).Font.Name = "VNI-Times"
End With
End With
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End If
End Sub
Đưa file, kèm theo mô tả mục đích, mọi người viết lại cho nhanh, chứ chỉnh mấy cái macro mất nhiều thời gian mà vẫn dễ có lỗi.
Nếu chỉ dùng code để copy dữ liệu không thì dùng code này.
Private Sub Workbook_Open()
Dim Wb As Workbook, tWb As Workbook
Set tWb = ThisWorkbook
tWb.Sheets("PO").Cells.ClearContents
tWb.Sheets("GIA").Cells.ClearContents
Set Wb = Workbooks.Open(tWb.Path & "\PO.xlsx")
Wb.Sheets(1).Cells.Copy tWb.Sheets("PO").Range("A1")
Wb.Close False
Set Wb = Workbooks.Open(tWb.Path & "\Gia.xlsx")
Wb.Sheets(1).Cells.Copy tWb.Sheets("Gia").Range("A1")
Wb.Close False
End SubDạ gửi A giaiphap
Dạ cảm ơn A giaiphap
