1. Yêu cầu thứ nhất - Chuyển công thức sang VBA: Bạn cứ thử copy công thức của 1 ô nào đó (chọn văn bản từ thanh công thức rồi copy), sau đó sử dụng chức năng Record New Macro và thực hiện thao tác: Chọn lại ô vừa sao chép công thức => Click vào thanh công thức và Ctrl+V để dán công thức vừa copy lúc nãy => Stop Record.Em gặp phải vấn đề trong file đính kèm và câu hỏi. Kính mong các bác giúp đỡ. Xin chân thành cảm ơn
[C11].FormulaR1C1 = "=IF(RC2="""","""",VLOOKUP(RC2,masp,2,0))"
Sub CongThucCotC()
Dim MyRange As Range, HangCuoi As Long
HangCuoi = [B65536].End(xlUp).Row
Set MyRange = Range("C11:C" & HangCuoi)
MyRange.FormulaR1C1 = "=IF(RC2="""","""",VLOOKUP(RC2,masp,2,0))"
End Sub
(Mà hình như mình thấy cái này quá quen luôn!1- Chuyển đổi công thức trong Sheet - Bao cao TH sang VBA (Do dữ liệu đầy đủ rất lớn và nhiều tháng
Option Explicit
Dim Sht As Worksheet, Rng0 As Range
Sub ThayCT()
Dim Sh As Worksheet, sRng As Range, Clls As Range, Rng As Range
Dim jJ As Byte
Set Sh = Sheets("DM"): Sheets("BCTh").Select
Set Rng = Sh.Range(Sh.[B6], Sh.[B65500].End(xlUp))
Set Sht = Sheets("NKNX")
Set Rng0 = Sht.Range(Sht.[H8], Sht.[H65500].End(xlUp))
Application.ScreenUpdating = False
For Each Clls In Range([B11], [B65500].End(xlUp))
Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
Clls.Offset(, 1).Resize(, 2).Value = sRng.Offset(, 1).Resize(, 2).Value
Clls.Offset(, 3).Value = sRng.Offset(, 5).Value
End If
For jJ = 4 To 27
If jJ <> 16 Then _
PhatSinh Cells(6, 2 + jJ).Value, jJ
Next jJ
Next Clls
End Sub
[B]Sub PhatSinh(GPE As String, Cot As Byte)[/B]
Dim sRng0 As Range, Clls As Range: Dim MyAdd As String
For Each Clls In Range([B11], [B65500].End(xlUp))
Set sRng0 = Rng0.Find(Clls.Value)
If sRng0 Is Nothing Then
Clls.Interior.ColorIndex = 35 + Clls.Row Mod 6
Else
MyAdd = sRng0.Address
Do
If sRng0.Offset(, -1).Value = GPE Then
Clls.Offset(, Cot).Value = Sht.Cells(sRng0.Row, "K").Value
End If
Set sRng0 = Rng0.FindNext(sRng0)
Loop While Not sRng0 Is Nothing And sRng0.Address <> MyAdd
End If
Next Clls
[B]End Sub[/B]
(Mà hình như mình thấy cái này quá quen luôn!
Nó ở đây nè bác!
http://www.giaiphapexcel.com/forum/showthread.php?t=28926
Option Explicit
'Khai báo biến dùng chung cho các macro:'
Dim Sht As Worksheet, Rng0 As Range
Sub ThayCT()
'Hai dòng khai báo các biến cần dùng trong macro:'
Dim Sh As Worksheet, sRng As Range, Clls As Range, Rng As Range
Dim jJ As Byte
'Gán Trang 'DM' vô biến đối tượng đã khai báo; Kích hoạt trang 'BCTh''
Set Sh = Sheets("DM"): Sheets("BCTh").Select
'Gán vùng là cột chứa mã của trang DM vô biến đối tượng Rng đã khai báo:'
Set Rng = Sh.Range(Sh.[B6], Sh.[B65500].End(xlUp))
'Gán trang NKNX vô biến đối tượng dùng chung đã khai báo:'
Set Sht = Sheets("NKNX")
'Gán vùng chứa mã trong trang NKNX vô biến dùng chung Rng0:'
Set Rng0 = Sht.Range(Sht.[H8], Sht.[H65500].End(xlUp))
'hống cập nhật màn hình:'
Application.ScreenUpdating = False
'Thiết lập vòng lặp qua tất cả các ô chứa mã trong trang tính hiện hành:'
For Each Clls In Range([B11], [B65500].End(xlUp))
'Áp dụng phương thức tìm kiếm với trị tìm là mã, tìm trong vùng chứa trong biến Rng:'
Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
'Nếu tìm thấy thì gán ô này vô biến sRng đã khai báo:'
If Not sRng Is Nothing Then
'Gán trị của 2 ô bên fải liền kề ô tìm thấy vô 2 ô fía fải liền kề ô chứa trị tìm:'
Clls.Offset(, 1).Resize(, 2).Value = sRng.Offset(, 1).Resize(, 2).Value
'Gán giá trị dư đầu kỳ từ DM sang:'
Clls.Offset(, 3).Value = sRng.Offset(, 5).Value
End If 'Kết thúc xét điều kiện'
'Thiết lập vòng lặp để chép các trị phát sinh nhập & xuất trong kỳ:'
For jJ = 4 To 27 '<=| Tất cả gồm 23 cột'
'Nếu khác cột 16 thì gọi thực hiện macro thứ 2:'
If jJ <> 16 Then _
PhatSinh Cells(6, 2 + jJ).Value, jJ
Next jJ 'Kết thúc vòng lặp trong; Sau đó kết thúc vòng lặp ngoài:'
Next Clls
End Sub
[B]Sub PhatSinh(GPE As String, Cot As Byte)[/B]
[COLOR=blue][B]'[/B]Tiếp tục khai báo các biến dùng trong macro này:'[/COLOR]
Dim sRng0 As Range, Clls As Range: Dim MyAdd As String
[COLOR=blue]'Thiết lập vòng lặp duyệt tất cả các ô chứa mã:'[/COLOR]
For Each Clls In Range([B11], [B65500].End(xlUp))
[COLOR=blue]'Tìm kiếm trị cần tìm trong biến vùng Rng0:'[/COLOR]
Set sRng0 = Rng0.Find(Clls.Value)
[COLOR=blue]'Nếu [B][I]không[/I][/B] tìm thấy (Thì gán chỉ số màu nền tương ứng cho ô đang duyệt'[/COLOR]
If sRng0 Is Nothing Then
Clls.Interior.ColorIndex = 35 + Clls.Row Mod 6
Else
[COLOR=blue]'Ngược lại thì gán địa chỉ ô tìm thấy vô biến MyAdd:'[/COLOR]
MyAdd = sRng0.Address
[COLOR=blue]'Tạo vòng lặp Do . . .Loop để tìm tất cả các mã hàng:'[/COLOR]
Do
[COLOR=blue]'Nếu trị chứa trong ô bên trái kề với ô tìm thấy trùng với tham trị được truyền, thì chép:'[/COLOR]
If sRng0.Offset(, -1).Value = GPE Then
[COLOR=blue]'Tiến hành chép trị chứa trong ô cột 'K' cùng dòng với ô tìm thấy vô cột thích hợp'[/COLOR]
[COLOR=blue]' của dòng chứa ô đang duyệt:'[/COLOR]
Clls.Offset(, Cot).Value = Sht.Cells(sRng0.Row, "K").Value
End If
[COLOR=blue]'Tiếp tục tìm cho đến hết các mã trùng:'[/COLOR]
Set sRng0 = Rng0.FindNext(sRng0)
[COLOR=blue]'Điều kiện để thoát vòng lặp Do . . . Loop:'[/COLOR]
Loop While Not sRng0 Is Nothing And sRng0.Address <> MyAdd
End If
Next Clls
[B]End Sub[/B]
Option Explicit
Dim Sht As Worksheet, Rng0 As Range
Sub BCTuan()
Dim NgDau As Date, NgCuoi As Date, Dat As Date
Dim SoNg As Integer, Jj As Long, Col As Byte: Dim CTu As String
Dim sRng As Range: Dim MyAdd As String
Set Sht = Sheets("NKNX"): Sheets("Tuan").Select
Set Rng0 = Sht.Range(Sht.[c8], Sht.[c65500].End(xlUp))
Rng0.NumberFormat = "MM/dd/yyyy"
If [ad1].Value = "All" Then 'Thong Kê Nguyên Nam:'
NgDau = DateSerial([ad2].Value, 1, 1)
NgCuoi = DateSerial([ad2].Value, 12, 31)
Else
If [m5].Value = "All" Then 'Thong Kê Nguyên Tháng:'
NgDau = DateSerial([ad2].Value, [ad1].Value, 1)
NgCuoi = DateSerial([ad2].Value, [ad1].Value + 1, 0)
Else 'Thong Kê Tuan/Vài Ngày:'
NgDau = DateSerial([ad2].Value, [ad1].Value, [m5].Value)
NgCuoi = DateSerial([ad2].Value, [ad1].Value, [M6].Value)
End If
End If
SoNg = NgCuoi - NgDau: Jj = [b12].End(xlDown).Row
If Jj > 65500 Then Jj = 65000
[b12].Resize(Jj, 16).ClearContents: [s12].Resize(Jj, 11).ClearContents
For Jj = 0 To SoNg
Dat = Jj + NgDau
Set sRng = Rng0.Find(Dat, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
CTu = sRng.Offset(, 4).Value
Col = Switch(CTu = "N-NKH", 6, CTu = "N-MUA", 7, CTu = "N-XGC", 8, CTu = "N-BID", _
9, CTu = "N-239", 10, CTu = "N-CRO", 11, CTu = "N-NBA", 12, CTu = "N-SON", 13, _
CTu = "N-MNA", 14, CTu = "N-VPH", 15, CTu = "N-THO", 16, CTu = "N-KHA", 17, _
CTu = "X-XGC", 19, CTu = "X-BID", 20, CTu = "X-239", 21, CTu = "X-CRO", 22, _
CTu = "X-NBA", 23, CTu = "X-SON", 24, CTu = "X-MNA", 25, CTu = "X-VPH", 26, _
CTu = "X-NBO", 27, CTu = "X-TAM", 28, CTu = "X-KHA", 29)
With [B65500].End(xlUp).Offset(1)
.Resize(, 3).Value = sRng.Offset(, 5).Resize(, 3).Value 'MaVT-> DVT'
.Offset(, 4).Value = "Du DK"
.Offset(, Col).Value = sRng.Offset(, 8).Value 'SoLuong'
End With
Set sRng = Rng0.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
Next Jj
End Sub
Option Explicit
Dim Sht As Worksheet, Rng0 As Range
Sub ThayCT()
Dim Sh As Worksheet, sRng As Range, Clls As Range, Rng As Range
Dim Jj As Byte
Dim sRng0 As Range, Cls As Range: Dim MyAdd As String
Set Sh = Sheets("DM"): Sheets("BCTh").Select
Set Rng = Sh.Range(Sh.[B6], Sh.[B65500].End(xlUp))
Set Sht = Sheets("NKNX")
Set Rng0 = Sht.Range(Sht.[H8], Sht.[H65500].End(xlUp))
Application.ScreenUpdating = False
For Each Clls In Range([B11], [B65500].End(xlUp))
Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
Clls.Offset(, 1).Resize(, 2).Value = sRng.Offset(, 1).Resize(, 2).Value
Clls.Offset(, 3).Value = sRng.Offset(, 5).Value
End If
For Jj = 4 To 27
If Jj <> 16 Then
' PhatSinh Cells(6, 2 + Jj).Value, Jj '
' GoTo 9 '
1 Set sRng0 = Rng0.Find(Clls.Value) '*'
If sRng0 Is Nothing Then
Clls.Interior.ColorIndex = 35 + Clls.Row Mod 6
Else
MyAdd = sRng0.Address
Do
If sRng0.Offset(, -1).Value = Cells(6, 2 + Jj).Value Then 'GPE'
Clls.Offset(, Jj).Value = Sht.Cells(sRng0.Row, "K").Value
End If
Set sRng0 = Rng0.FindNext(sRng0)
Loop While Not sRng0 Is Nothing And sRng0.Address <> MyAdd
End If
9 End If
Next Jj
Next Clls
End Sub
(2) Dùng cái ni thay cho 2 macro ở bài 3 & thời lượng có thể giảm 20 lần hay hơn!
(1) Câu hai của bạn đây, xin mời mại zô!
- Do không cần tính toán số dư nên laọi bỏ cột số dư đầu kỳ. Đã sửa lại địa chỉ trong code - OK
(3)
- Vấn đề lớn nhất là DL chỉ liệt kê NX từ ngày đến ngày do đó các mã, tên vật tư xuất hiện nhiều lần (em mong muốn nó xuất hiện 1 tên duy nhất và số lượng cộng dồn như CT "Sumif").
Vậy bác xem lại giúp em với nhé. Cảm ơn bác trước!
[b12].Resize(Js, 16).ClearContents: [s12].Resize(Js, 11).ClearContents '<=|'
- Vấn đề lớn nhất là DL chỉ liệt kê NX từ ngày đến ngày do đó các mã, tên vật tư xuất hiện nhiều lần (em mong muốn nó xuất hiện 1 tên duy nhất và số lượng cộng dồn như CT "Sumif").
Vậy bác xem lại giúp em với nhé. Cảm ơn bác trước
Option Explicit
Sub AdvFilter() '{CTRL}+{SHIFT}+F'
Dim eRw As Long, Col As Byte
Dim Clls As Range, Sh As Worksheet
Dim MaHg As String, CTu As String
Set Sh = Sheets("Tuan"): eRw = Sh.[b65500].End(xlUp).Row
Sh.[B12].Resize(eRw, 15).Clear
Sh.[r12].Resize(eRw, 11).Clear
Sheets("NKNX").Select: eRw = [c65500].End(xlUp).Row
Range("C8:K" & eRw).AdvancedFilter Action:=2, _
CriteriaRange:=[U2].Resize(2, 2), CopyToRange:=[U8].Resize(, 9)
Range("U8:AC" & eRw).Sort Key1:=Range("Z9"), Order1:=xlAscending, _
Key2:=Range("W9"), Order2:=xlAscending, Header:=xlGuess
For Each Clls In Range([z9], [z65500].End(xlUp))
CTu = Clls.Offset(, -1).Value
Col = Switch(CTu = "N-NKH", 5, CTu = "N-MUA", 6, CTu = "N-XGC", 7, CTu = "N-BID", _
8, CTu = "N-239", 9, CTu = "N-CRO", 10, CTu = "N-NBA", 11, CTu = "N-SON", 12, _
CTu = "N-MNA", 13, CTu = "N-VPH", 14, CTu = "N-THO", 15, CTu = "N-KHA", 16, _
CTu = "X-XGC", 18, CTu = "X-BID", 19, CTu = "X-239", 20, CTu = "X-CRO", 21, _
CTu = "X-NBA", 22, CTu = "X-SON", 23, CTu = "X-MNA", 24, CTu = "X-VPH", 25, _
CTu = "X-NBO", 26, CTu = "X-TAM", 27, CTu = "X-KHA", 28)
If Clls.Value <> MaHg Then
MaHg = Clls.Value: eRw = 1 + Sh.[b65500].End(xlUp).Row
Sh.Cells(eRw, "B").Resize(, 3).Value = Clls.Resize(, 3).Value
Sh.Cells(eRw, Col).Value = Clls.Offset(, 3).Value 'SoLuong'
Else
Sh.Cells(eRw, "B").Interior.ColorIndex = 34 + eRw Mod 6
Sh.Cells(eRw, Col).Value = Clls.Offset(, 3).Value + Sh.Cells(eRw, Col).Value
End If
Next Clls
Sh.Select: Set Sh = Nothing
End Sub