Những câu hỏi về code, xin giải thích các code, đề nghị các bạn gửi vào đây (1 người xem)

ST-Lu! · 23/10/08

Kể từ hôm nay, tất cả những câu hỏi nhờ giải thích dùm một đoạn code, hay là hỏi những vấn đề linh tinh gì liên quan đến cách viết code, đề nghị các bạn gửi chung vào đây.

Những đề tài mới với tiêu đề: "Nhờ giải thích dùm đoạn code", mà không nói rõ là code gì, code dùng để làm gì, sẽ bị xóa.

BQT
----------------------------------------------------------------------------------------------------------------

Em xin được hỏi 2 đoạn code sau có tương đương nhau ?

Cells(Cells.Rows.Count, 1).End(xlUp).Row có tương đương với [A65000].End(xlup).row

Cám ơn các anh chỉ giáo

Hong.Van · 4/1/13

seishirou_sama đã viết:
Cho mình hỏi anh/chị có thể chia sẻ công thức macro tự chạy công thức excel không ạ ví dụ như khi mình tính toán cho ô a1 và a2 công thức ở ô b1 thì công thức sẽ tự động link xuống các ô b2, b3, b4 mà không cần kéo tay. Như ở file đính kèm ạ

Cái này dùng Data/List là được

kyo · 4/1/13

hungpecc1 đã viết:
Diễn đàn giải thích giúp e đoạn code sau :
Chk = (InStr("><=", Left(FindStr, 1)) > 0)

Hàm InStr là hàm dò tìm ký tự hay một cụm ký tự có trong chuỗi.
Cú pháp hàm là: InStr([start, ]string1, string2[, compare])
Ở đây, string1 là chuỗi cần dò tìm (của bạn là chuỗi "><="), string2 là ký tự tìm trong chuỗi (của bạn là ký tự đầu tiên của biến FindStr).
Giả sử ký tự đầu tiên của biến FindStr là <, vậy thì Chk của bạn là True vì nó lớn hơn 0 rồi.

thanhlanh · 4/1/13

Hoàng Trọng Nghĩa đã viết:
Nhìn cái này quen quen, giống hàm Filter2DArray của Thầy NDU quá ta?

Biến Chk này có kiểu là Boolean, trả về True hoặc False

Hàm InStr(xxx) như hàm Find/ Search trong công thức Excel, nó tìm ra vị trí ký tự nó tìm thấy.

Với biến FindStr có kiểu String, là một chuỗi mà khi ở ký tự này nếu có 1 trong các ký tự > , < , = ở đầu chuỗi (hàm Left lấy ký tự đầu) thì cụm công thức (InStr("><=", Left(FindStr, 1)) > 0) sẽ trả về giá trị True, còn không tìm thấy sẽ trả về giá trị False.

Minh hoạ thêm cho bạn ấy dể hiểu, thử chạy code này và kết luận

Mã:

Sub test()
    Dim chk, FindStr
    FindStr = "= 1000000"
    MsgBox InStr("><=", Left(FindStr, 1))
    chk = InStr("><=", Left(FindStr, 1)) > 0
    MsgBox TypeName(chk)
End Sub

newmenber · 6/1/13

Cho em hỏi, cái bẫy lỗi này sao chỉ làm việc được có 1 lần. Cụ thể là trong folder "Luc nhan su" có các file 001-12, 005-12, 006-12, 009-12....(khoảng hơn 300 file nhưng số không liên tục, chẳng hạn không có file 003-12 và 004-12...). em muốn là nếu file không có thì chương trình tự bỏ qua và tăng j lên. Nhưng chỉ được 1 lần, chương trình báo lỗi là không có file 004-12.

Sub locnhansu()
For j = 1 To 500
n = Format(j, "000")
Fname = "J:\Luc nhan su\" & n & "-12.xls"
On Error GoTo Tiep
Workbooks.Open Fname
.....
các lệnh
......
ActiveWorkbook.Close SaveChanges:=False
Tiep:
Next
End sub

dhn46 · 6/1/13

Bạn thử đưa dòng

Mã:

[COLOR=#000000]        On Error GoTo Tiep
[/COLOR]

Lên sau dòng

Mã:

[/COLOR][COLOR=#000000]Sub locnhansu()
[/COLOR]

Hong.Van · 7/1/13

Thắc mắc AddIns lạ
-------------------------------
Em thấy trong Excel của em có 1 Addin lạ, em kg hiểu công dụng nó làm gì?
Em nhờ thầy cô & anh chị nó sơ lược công dụng của Addin này ? để nếu kg cần thiết thì để em xóa!

Pass code Wildebeest!!
Em cảm ơn!

ndu96081631 · 7/1/13

Hong.Van đã viết:
Thắc mắc AddIns lạ
-------------------------------
Em thấy trong Excel của em có 1 Addin lạ, em kg hiểu công dụng nó làm gì?
Em nhờ thầy cô & anh chị nó sơ lược công dụng của Addin này ? để nếu kg cần thiết thì để em xóa!

Pass code Wildebeest!!
Em cảm ơn!

Code này y chang với code của Analysis ToolPak - VBA
Vậy thì xài thằng Analysis ToolPak - VBA là được rồi ---> Cái lạ lạ kia xóa bớt đi

bienda · 7/1/13

Range("Node").EntireRow.Select
Selection.Insert Shift:=xlDown
ActiveCell.Offset(-1, 0).Rows("1:2").EntireRow.Select
Selection.FillDown
ActiveCell.Offset(1, 2).Range("A1:B1").Select
Selection().ClearContents

ActiveCell.Select

Nhờ các bác giải thích các thao tác thực hiện trên bảng Excel đoạn code trên
K biết là đoạn macro trên đã chỉnh sưa chưa
Em làm mãi macro mà không ra code như trên +-+-+-+

Cảm ơn rất nhiều

Thôi, cảm ơn các bác nhiều, em tự vọc và hiểu rồi -+*/

kstruong2005 · 12/1/13

Nhờ các cao thủ giải dùm code VBA này!

Private Sub CommandButton2_Click()
Sheets("Du lieu loc").Range("A4:G10000").Delete ' Xóa dữ liệu vùng "A4:G10000"
Sheets("Du lieu goc").Range("A4:G10000").Copy ' copy dữ liệu vùng "A4:G10000"
Sheets("Du lieu loc").Range("A4").Select ' Sheet dữ liệu lọc vùng "A4" chọn
ActiveSheet.Paste
Range("H3").Select
Dim i, j, n, dau, cuoi, max As Integer ' Đến chỗ này em không hiểu mong mọi người giúp đỡ chú giải dùm em.
n = 4
Do While Cells(n, "A") <> ""
n = n + 1
Loop
n = n - 1
i = 4
dau = 4
Cells(dau, "H") = "*"
'dua cac gia tri max le dong dau
For i = dau To n
If Cells(i, "A") = Cells(i + 1, "A") Then
If Cells(dau, "C") < Cells(i + 1, "C") Then
Cells(dau, "B") = Cells(i + 1, "B")
Cells(dau, "C") = Cells(i + 1, "C")
Cells(dau, "F") = Cells(i + 1, "F")
Cells(dau, "G") = Cells(i + 1, "G")
End If
If Abs(Cells(dau, "D")) < Abs(Cells(i + 1, "D")) Then
Cells(dau, "D") = Cells(i + 1, "D")
End If
If Abs(Cells(dau, "E")) < Abs(Cells(i + 1, "E")) Then
Cells(dau, "E") = Cells(i + 1, "E")
End If
Else
dau = i + 1
Cells(dau, "H") = "*"
End If
Next i

'Xoa cac dong khong chua Pmax
i = 4
Do While Cells(i, "A") <> ""
If Cells(i, "H") <> "*" Then
Rows(i).Delete
Else
i = i + 1
End If
Loop
Range("H:H").ClearContents
i = 4
Do While Cells(i, "A") <> ""
i = i + 1
Loop
i = i - 1
Range(Cells(4, 1), Cells(i, 7)).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
Range("H16").Select
End Sub

ChanhTQ@ · 12/1/13

[thongbao]Nhờ các cao thủ giải dùm code VBA này![/thongbao]

(1) Giải là nghĩa làm sao vậy bạn?

PHP:

     Giải thích, giải nghĩa (nghĩa là dịch từ VBA sang tiếng Việt)?
  
     Giải quyết: Sửa chữa, đi đến kết thúc
 
      . . . . . .

(2) Mà sao bạn không dùng chức năng [PHP ]. . . [/php] để dễ đọc làm vậy?

Bạn làm như người khác rỗi việc lắm vậy đó; . . . Thấy chán là họ bỏ đi chỗ khác vui hơn liền hà!

Thân & chúc cuối tuần zui zẻ!

Quang_Hải · 12/1/13

kstruong2005 đã viết:
Private Sub CommandButton2_Click()
Sheets("Du lieu loc").Range("A4:G10000").Delete ' Xóa dữ liệu vùng "A4:G10000"
Sheets("Du lieu goc").Range("A4:G10000").Copy ' copy dữ liệu vùng "A4:G10000"
Sheets("Du lieu loc").Range("A4").Select ' Sheet dữ liệu lọc vùng "A4" chọn
ActiveSheet.Paste
Range("H3").Select
Dim i, j, n, dau, cuoi, max As Integer ' Đến chỗ này em không hiểu mong mọi người giúp đỡ chú giải dùm em.

1. Tìm tài liệu VBA căn bản đọc ngấu nghiến trong 6 tháng
2. Tìm trường lớp học trong 3 tháng sẽ nắm hết căn bản
3. Thôi kệ mấy cái code quỷ quái đó đi. Muốn chạy sao cũng được miễn có kết quả là ok rồi

nghiepdung · 14/1/13

Cho em hỏi đoạn code này là như nào ạ

Public Sub GPE()
Dim Arr(), I As Long, J As Long
Arr = Range([D7], [D65000].End(xlUp)).Resize(, 6).Value
For I = 1 To UBound(Arr, 1)
Arr(I, 3) = Arr(I, 3) + Arr(I, 2)
Arr(I, 5) = Arr(I, 5) + Arr(I, 4)
Arr(I, 6) = Arr(I, 3) - Arr(I, 5)
Arr(I, 2) = 0: Arr(I, 4) = 0
Next I
[D7].Resize(I - 1, 6).Value = Arr
End Sub

thanhlanh · 14/1/13

nghiepdung đã viết:
Cho em hỏi đoạn code này là như nào ạ

Public Sub GPE()
Dim Arr(), I As Long, J As Long
Arr = Range([D7], [D65000].End(xlUp)).Resize(, 6).Value ' = Đưa vùng dữ liệu từ ô D1 đến ô cuối cùng có dữ liệu của cột D, mở rộng ra đủ 6 cột ---> vào mảng Arr

For I = 1 To UBound(Arr, 1) ' Cho biến I chạy từng dòng từ đầu đến cuối (theo chiều thứ nhất) của mảng Arr

Arr(I, 3) = Arr(I, 3) + Arr(I, 2) ' tại mỗi dòng, cộng thêm cột thứ 2 vào cột thứ 3
Arr(I, 5) = Arr(I, 5) + Arr(I, 4) ' tt
Arr(I, 6) = Arr(I, 3) - Arr(I, 5) ' tt

Arr(I, 2) = 0: Arr(I, 4) = 0 ' cho cột thứ 2 và thứ 4 bằng 0
Next I
[D7].Resize(I - 1, 6).Value = Arr ' Đưa mảng vào Cells, ở đây nó được gán vào vị trí cũ (D7)
End Sub

thaonguyenxanh3691 · 16/1/13

cho em hỏi code này có vấn đề gì không

em nhập mã code để giải phương trình bậc 2 nhưng nếu em cho thêm dòng tính denta vào bảng thì tính ra kết quả đúng mà xuất sang excel cũng đúng còn bỏ dòng tính denta đi nó tính sai nhưng khi xuất sang excel vẫn cho nghiệm đúng
D ở đây là denta

Option Explicit
Dim a As Double, b As Double, c As Double
Dim X1 As Double, X2 As Double, D As Double, X As Double
Public Sub CmdTinh_Click()
a = UserForm1.Txta.Text
b = UserForm1.Txtb.Text
c = UserForm1.Txtc.Text
D = b ^ 2 - 4 * a * c
Select Case D
Case Is > 0
FrmKetqua.Caption = "Phuong trinh da cho co hai nghiem phan biet:"
a = UserForm1.Txta.Text
b = UserForm1.Txtb.Text
c = UserForm1.Txtc.Text
X1 = -b / (2 * a) - D ^ (1 / 2) / (2 * a)
X2 = -b / (2 * a) + D ^ (1 / 2) / (2 * a)
LalGT1.Caption = "X1="
LalGT2.Caption = "X2="
TxtGT1.Visible = True
TxtGT2.Visible = True
LalGT1.Visible = True
LalGT2.Visible = True
Case Is = 0
FrmKetqua.Caption = "Phuong trinh da cho co nghiem kep:"
a = UserForm1.Txta.Text
b = UserForm1.Txtb.Text
c = UserForm1.Txtc.Text
X = -b / (2 * a)
LalGT1.Caption = "X="
LalGT2.Visible = False
TxtGT2.Visible = False
TxtGT1.Visible = True
LalGT1.Visible = True
Case Else
FrmKetqua.Caption = "Phuong trinh da cho vo nghiem"
LalGT1.Visible = False
LalGT2.Visible = False
TxtGT1.Visible = False
TxtGT2.Visible = False
End Select
UserForm1.TxtGT1.Text = Round(X1, 3)
UserForm1.TxtGT2.Text = Round(X2, 3)
UserForm1.TxtGT1.Text = Round(X, 3)
End Sub
Public Sub CmdExcel_Click()
CmdTinh_Click
Select Case D
Case Is > 0
ThisWorkbook.Worksheets(1).Range("A1:B3").Clear
ThisWorkbook.Worksheets(1).Range("A1").Value = "phuong trinh da cho co hai nghiem phan biet:"
ThisWorkbook.Worksheets(1).Range("A2").Value = "X1="
ThisWorkbook.Worksheets(1).Range("B2").Value = Round(X1, 3)
ThisWorkbook.Worksheets(1).Range("A3").Value = "X2="
ThisWorkbook.Worksheets(1).Range("B3").Value = Round(X2, 3)
Case Is = 0
ThisWorkbook.Worksheets(1).Range("A1:B3").Clear
ThisWorkbook.Worksheets(1).Range("A1").Value = "phuong trinh da cho co nghiem kep:"
ThisWorkbook.Worksheets(1).Range("A2").Value = "X="
ThisWorkbook.Worksheets(1).Range("B2").Value = Round(X, 3)
Case Else
ThisWorkbook.Worksheets(1).Range("A1:B3").Clear
ThisWorkbook.Worksheets(1).Range("A1").Value = "phuong trinh da cho vo nghiem"
End Select
ThisWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit
End Sub
Public Sub CmdThoat_Click()
UserForm1.Hide
End Sub

kyo · 16/1/13

thaonguyenxanh3691 đã viết:
em nhập mã code để giải phương trình bậc 2 nhưng nếu em cho thêm dòng tính denta vào bảng thì tính ra kết quả đúng mà xuất sang excel cũng đúng còn bỏ dòng tính denta đi nó tính sai nhưng khi xuất sang excel vẫn cho nghiệm đúng
D ở đây là denta

Option Explicit
Dim a As Double, b As Double, c As Double
Dim X1 As Double, X2 As Double, D As Double, X As Double
Public Sub CmdTinh_Click()
a = UserForm1.Txta.Text
b = UserForm1.Txtb.Text
c = UserForm1.Txtc.Text
D = b ^ 2 - 4 * a * c
Select Case D
Case Is > 0
FrmKetqua.Caption = "Phuong trinh da cho co hai nghiem phan biet:"
a = UserForm1.Txta.Text
b = UserForm1.Txtb.Text
c = UserForm1.Txtc.Text
X1 = -b / (2 * a) - D ^ (1 / 2) / (2 * a)
X2 = -b / (2 * a) + D ^ (1 / 2) / (2 * a)
LalGT1.Caption = "X1="
LalGT2.Caption = "X2="
TxtGT1.Visible = True
TxtGT2.Visible = True
LalGT1.Visible = True
LalGT2.Visible = True
Case Is = 0
FrmKetqua.Caption = "Phuong trinh da cho co nghiem kep:"
a = UserForm1.Txta.Text
b = UserForm1.Txtb.Text
c = UserForm1.Txtc.Text
X = -b / (2 * a)
LalGT1.Caption = "X="
LalGT2.Visible = False
TxtGT2.Visible = False
TxtGT1.Visible = True
LalGT1.Visible = True
Case Else
FrmKetqua.Caption = "Phuong trinh da cho vo nghiem"
LalGT1.Visible = False
LalGT2.Visible = False
TxtGT1.Visible = False
TxtGT2.Visible = False
End Select
UserForm1.TxtGT1.Text = Round(X1, 3)
UserForm1.TxtGT2.Text = Round(X2, 3)
UserForm1.TxtGT1.Text = Round(X, 3)
End Sub
Public Sub CmdExcel_Click()
CmdTinh_Click
Select Case D
Case Is > 0
ThisWorkbook.Worksheets(1).Range("A1:B3").Clear
ThisWorkbook.Worksheets(1).Range("A1").Value = "phuong trinh da cho co hai nghiem phan biet:"
ThisWorkbook.Worksheets(1).Range("A2").Value = "X1="
ThisWorkbook.Worksheets(1).Range("B2").Value = Round(X1, 3)
ThisWorkbook.Worksheets(1).Range("A3").Value = "X2="
ThisWorkbook.Worksheets(1).Range("B3").Value = Round(X2, 3)
Case Is = 0
ThisWorkbook.Worksheets(1).Range("A1:B3").Clear
ThisWorkbook.Worksheets(1).Range("A1").Value = "phuong trinh da cho co nghiem kep:"
ThisWorkbook.Worksheets(1).Range("A2").Value = "X="
ThisWorkbook.Worksheets(1).Range("B2").Value = Round(X, 3)
Case Else
ThisWorkbook.Worksheets(1).Range("A1:B3").Clear
ThisWorkbook.Worksheets(1).Range("A1").Value = "phuong trinh da cho vo nghiem"
End Select
ThisWorkbook.Worksheets(1).Columns("A:B").EntireColumn.AutoFit
End Sub
Public Sub CmdThoat_Click()
UserForm1.Hide
End Sub

Đọc mãi mới hiểu bạn muốn gì, hic.

Mã:

    [B]UserForm1.TxtGT1.Text = Round(D, 3)[/B] 'bị thừa
    UserForm1.TxtGT1.Text = Round(X1, 3) 'đưa cái này vào Case D > 0
    UserForm1.TxtGT2.Text = Round(X2, 3) 'đưa cái này vào Case D > 0
    [B]UserForm1.TxtGT1.Text = Round(X, 3)[/B] 'đưa cái này vào Case D = 0

Đây chính xác là chỗ bạn bị lỗi ở file giai pt2. Khi bạn giải ra hai nghiệm phân biệt, tức là biến X1 và X2 của bạn có số. Tuy vậy, biến X lại = 0. Do đó, khi ra X1 X2 và điền vào 2 textbox xong, biến X = 0 lại được điền vào textbox TxtGT1 dẫn đến X1 của bạn luôn = 0. Còn việc khi xuất ra file Excel kết quả của bạn vẫn đúng là do bạn xuất bằng biến chứ không xuất bằng giá trị của textbox nên những gì thể hiện trên textbox không hề liên quan đến việc xuất ra Excel.

Do đó, bạn có thể sửa lại bằng cách như ghi chú kyo có ghi kèm phía trên.

chicpt4748 · 18/1/13

Nhờ Pro giải thích dùm code Xóa các dòng trùng có điều kiện

Xin giải thich hộ mình Code. Chân thành cảm ơn.[GPECODE=vb]Sub DeleteArr()Dim T, i As Long, s As Long, k As Long
Dim Arr(), ArrKQ()
Dim Dic As Object, Xoa As String
T = Timer()
Set Dic = CreateObject("Scripting.Dictionary")
Sheets("Data").Select
Arr = Range([A3], [u65000].End(xlUp)).Value
ReDim ArrKQ(1 To UBound(Arr), 1 To 21)
s = 0
For i = 1 To UBound(Arr)

If Not Dic.exists(Arr(i, 1)) Then
s = s + 1
For k = 1 To 21
ArrKQ(s, k) = Arr(i, k)
Next k
Dic.Add Arr(i, 1), i
End If

Next i
With [A3]
.Resize(i, 21).ClearContents
.Resize(s, 21).Value = ArrKQ
End With
MsgBox Timer() - T

End Sub[/GPECODE]

ndu96081631 · 18/1/13

chicpt4748 đã viết:
Xin giải thich hộ mình Code. Chân thành cảm ơn.

Thật ra code này chẳng phải xóa dòng gì cả
Nó lọc dữ liệu trong vùng A:U, phần tử nào của cột 1 bị trùng thì chỉ lấy 1 thôi. Sau khi lọc, kết quả được cho vào mảng rồi gán ngược xuống sheet
Để lọc duy nhất (Unique) người ta dùng Dictionary. Bạn có thể tham khảo Dictionary tại đây:
http://www.giaiphapexcel.com/forum/showthread.php?60643-Tổng-quan-về-Scripting-Dictionary

LienDong · 23/1/13

Nhờ rút gọn code Copy
----------------------
Mình có ReCord Macros, macros này mở một file khác và copy, nhờ các bạn rút gọn giùm code này

Mã:

Sub Macro5()

    Workbooks.Open Filename:="D:\DuAnMoi\Tao_1.xls"
    Sheets("DS_Khac").Select
    Range("L2:W4").Select
    Selection.Copy
    Windows("Tao_2.xls").Activate
    Range("BQ2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("Tao_1.xls").Activate
    Application.CutCopyMode = False
    ActiveWindow.Close
    Range("BQ5").Select
End Sub

Cảm ơn các bạn!

ndu96081631 · 23/1/13

LienDong đã viết:
Nhờ rút gọn code Copy
----------------------
Mình có ReCord Macros, macros này mở một file khác và copy, nhờ các bạn rút gọn giùm code này

Mã:

Sub Macro5() Workbooks.Open Filename:="D:\DuAnMoi\Tao_1.xls" Sheets("DS_Khac").Select Range("L2:W4").Select Selection.Copy Windows("Tao_2.xls").Activate Range("BQ2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Windows("Tao_1.xls").Activate Application.CutCopyMode = False ActiveWindow.Close Range("BQ5").Select End Sub

Cảm ơn các bạn!

Đầu tiên bạn phải cho mọi người biết:
- Windows("Tao_2.xls") là cái gì? Có phải là Workbook đang chứa code không?
- Copy từ Tao_1.xls sang Tao_2.xls, vậy paste vào sheet nào?
-----------
Tôi giả định là Tao_2 là Thisworkbook và việc copy paste là paste vào ActiveSheet của Tao_2 nhé:

Mã:

  Dim FileName As String, wkb As Workbook
  Set wkb = ThisWorkbook
  FileName = "D:\DuAnMoi\Tao_1.xls"
  With Workbooks.Open(FileName)
    .Sheets("DS_Khac").Range("L2:W4").Copy
    wkb.ActiveSheet.Range("BQ2").PasteSpecial 3
    .Close False
  End With
End Sub

cuong0202 · 24/1/13

Private Sub cmdxoa_Click()
If DCount("MANCC", "phieunhapkho", "MANCC='" & MANCC & "'") > 0 Then
MsgBox "Can't not delete because it has incurred"
ElseIf MsgBox("Do you realy delete this item ?", vbYesNo + vbQuestion, "Warning") = vbYes Then
DoCmd.SetWarnings False
DoCmd.RunCommand acCmdDeleteRecord
LNCC.Requery
DoCmd.GoToRecord , , acLast
End If
End Sub

Mình tạo 1 nút xóa,,, nó sẽ tìm ở table "phieunhapkho" nếu table này ko có sử dụng cái mã mà mình muốn xóa ,, nó sẽ cho xóa,,,,
bây giờ nó cái mã đó có thể phát sinh thêm ở table "phieuxuatkho"

Vậy mình phải sữa đoạn code trên lại như thế nào??? nhớ mọi người xem giúp.

dongducnhiem · 30/1/13

Nhờ các bạn giúp viết code cho dòng TỔNG CỘNG như sau :
Ô C159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(C$10:C$158))

Ô D159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(D$10:D$158))

Ô E159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(E$10:E$158))

Ô F159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(F$10:F$158))

Ô G159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(G$10:G$158))

Ô H159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(H$10:H$158))

Các bạn lưu ý
1/ Dòng Tổng Cộng này sẽ không cố định, nó có thể bị dời lên hay dời xuống
2/ Vui lòng viết code để trong Module
Cảm ơn các bạn!

dongducnhiem · 30/1/13

dongducnhiem đã viết:
Nhờ các bạn giúp viết code cho dòng TỔNG CỘNG như sau :
Ô C159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(C$10:C$158))

Ô D159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(D$10:D$158))

Ô E159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(E$10:E$158))

Ô F159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(F$10:F$158))

Ô G159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(G$10:G$158))

Ô H159

PHP:

=SUMPRODUCT((CODE($B$10:$B$158)>72)*(CODE($B$10:$B$158)<87)*(H$10:H$158))

Các bạn lưu ý
1/ Dòng Tổng Cộng này sẽ không cố định, nó có thể bị dời lên hay dời xuống
2/ Vui lòng viết code để trong Module
Cảm ơn các bạn!

Ý cùa mình là lập các công thức trên cho dòng Tổng cộng rồi sau đó Paste Value luôn cho dòng này. Vì hiện nay tôi đang dùng 1 code khác, mà code này khi chạy thì nó Paste Value toàn bộ bảng tính. Xin cảm ơn
---------
P/S Vì mỗi tháng sẽ phát sinh các Sheet như Thang01, Thang02 ....Thang12, tôi định đặt Name, nếu như vậy đặt name cho mỗi Tháng thì nhiều quá!

dhn46 · 31/1/13

dongducnhiem đã viết:
Ý cùa mình là lập các công thức trên cho dòng Tổng cộng rồi sau đó Paste Value luôn cho dòng này. Vì hiện nay tôi đang dùng 1 code khác, mà code này khi chạy thì nó Paste Value toàn bộ bảng tính. Xin cảm ơn
---------
P/S Vì mỗi tháng sẽ phát sinh các Sheet như Thang01, Thang02 ....Thang12, tôi định đặt Name, nếu như vậy đặt name cho mỗi Tháng thì nhiều quá!

Bạn dùng Code sau và đảm bảo rằng dòng liền sau dòng 159 là trống, ô A159 không rỗng (A159 - ô cuối vũng dữ liệu)

Mã:

Sub Total()
Dim Arr, sArr, i As Long, j As Long
Arr = Range("A10", Range("A10").End(xlDown)).Resize(, Range("a10").End(xlToRight).Column)
ReDim sArr(1 To 1, 1 To UBound(Arr, 2) - 2)


For i = 1 To UBound(Arr, 1)
    If Not IsNumeric(Arr(i, 2)) Then
        For j = 3 To UBound(Arr, 2)
            sArr(1, j - 2) = sArr(1, j - 2) + Arr(i, j)
        Next
    End If
Next
Range("C" & Range("A10").End(xlDown).Row).Resize(, UBound(sArr, 2)) = sArr
End Sub

Hong.Van · 31/1/13

dongducnhiem đã viết:
Ý cùa mình là lập các công thức trên cho dòng Tổng cộng rồi sau đó Paste Value luôn cho dòng này. Vì hiện nay tôi đang dùng 1 code khác, mà code này khi chạy thì nó Paste Value toàn bộ bảng tính. Xin cảm ơn
---------
P/S Vì mỗi tháng sẽ phát sinh các Sheet như Thang01, Thang02 ....Thang12, tôi định đặt Name, nếu như vậy đặt name cho mỗi Tháng thì nhiều quá!

Góp vui thêm 1 cách, chơi xong thì bỏ!!!

Mã:

Sub TongCong()    
    With ActiveSheet
        Range("B10:B" & [B65536].End(3).Row).Name = "BBBB"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 1).Name = "CCCC"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 2).Name = "DDDD"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 3).Name = "EEEE"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 4).Name = "FFFF"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 5).Name = "GGGG"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 6).Name = "HHHH"
    End With
    [B50000].End(xlUp).Offset(1, 1).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(CCCC))"
    [B50000].End(xlUp).Offset(1, 2).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(DDDD))"
    [B50000].End(xlUp).Offset(1, 3).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(EEEE))"
    [B50000].End(xlUp).Offset(1, 4).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(FFFF))"
    [B50000].End(xlUp).Offset(1, 5).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(GGGG))"
    [B50000].End(xlUp).Offset(1, 6).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(HHHH))"
    With Range([A10], [A5000].End(xlUp)).Resize(, 8)
        .Value = .Value
    End With
    ActiveWorkbook.Names("BBBB").Delete
    ActiveWorkbook.Names("CCCC").Delete
    ActiveWorkbook.Names("DDDD").Delete
    ActiveWorkbook.Names("EEEE").Delete
    ActiveWorkbook.Names("FFFF").Delete
    ActiveWorkbook.Names("GGGG").Delete
    ActiveWorkbook.Names("HHHH").Delete
End Sub

Quang_Hải · 31/1/13

Hong.Van đã viết:

Góp vui thêm 1 cách, chơi xong thì bỏ!!!

Mã:

Sub TongCong()    
    With ActiveSheet
        Range("B10:B" & [B65536].End(3).Row).Name = "BBBB"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 1).Name = "CCCC"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 2).Name = "DDDD"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 3).Name = "EEEE"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 4).Name = "FFFF"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 5).Name = "GGGG"
        Range("B10:B" & [B65536].End(3).Row).Offset(, 6).Name = "HHHH"
    End With
    [B50000].End(xlUp).Offset(1, 1).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(CCCC))"
    [B50000].End(xlUp).Offset(1, 2).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(DDDD))"
    [B50000].End(xlUp).Offset(1, 3).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(EEEE))"
    [B50000].End(xlUp).Offset(1, 4).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(FFFF))"
    [B50000].End(xlUp).Offset(1, 5).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(GGGG))"
    [B50000].End(xlUp).Offset(1, 6).Value = "=SUMPRODUCT((CODE(BBBB)>72)*(CODE(BBBB)<87)*(HHHH))"
    With Range([A10], [A5000].End(xlUp)).Resize(, 8)
        .Value = .Value
    End With
    ActiveWorkbook.Names("BBBB").Delete
    ActiveWorkbook.Names("CCCC").Delete
    ActiveWorkbook.Names("DDDD").Delete
    ActiveWorkbook.Names("EEEE").Delete
    ActiveWorkbook.Names("FFFF").Delete
    ActiveWorkbook.Names("GGGG").Delete
    ActiveWorkbook.Names("HHHH").Delete
End Sub

Nếu là mình thì mình sẽ làm thế này nhìn cho đẹp tí

PHP:

Sub TongCong()
Dim Sname, i
Sname = Array("BBBB", "CCCC", "DDDD", "EEEE", "FFFF", "GGGG", "HHHH")
For i = 0 To 6
   Range("B10:B" & [B65536].End(3).Row).Offset(0, i).Name = Sname(i)
Next
'......................
For i = 0 To 6
    ActiveWorkbook.Names(Sname(i)).Delete
Next

End Sub

songdai_love · 31/1/13

Mong các thầy chỉ em với

Em có phiếu chứng từ , và em muốn gán 1 nút cmd để khi nhấp vào nút khai báo sẽ hiện tất cả các dòng bị ẩn, khi khai báo xong em click xong sẽ ẩn tất cả các dòng rỗng và = 0 nhưng những dòng có dữ liệu thì để lại đồng thời protect hết tất cả không cho chỉnh sữa, nhưng em viết code như thế này thì nó ẩn hết tất cả nd và dòng rỗng, mong các thầy chỉnh lại giúp em. Cám ơn. Em có file đính kèm

Sub Cmd_Click()
Sheets("CT").Unprotect "3624"
DK = Cmd.Caption = "Xong"
Range("A3:A1599").SpecialCells(3, 22).EntireRow.Hidden = DK
Cmd.Caption = Choose(-1 * DK + 1, "Xong", "Khai bao")
Sheets("CT").Protect "3624"
End Sub

hoanglocphat · 31/1/13

Các bạn cho mình hỏi, cách clear format các màu tô số liệu
Trong File mình có nhiều màu tô số liệu ví dụ màu nâu (.Font.ColorIndex = 13) màu đỏ (.Font.ColorIndex = 3) ...
Bây giờ mình muốn xóa hết các màu chỉ giữ lại màu nâu ? thì code viết như thế nào?
cảm ơn các bạn

mystery83 · 31/1/13

Help file excel với VBA

Hiện tại mình đang có 1 file excel.Mình đã viết 1 số công thức trên đó bằng VBA.

HIện tại mình cần thao tác kiểm tra giá trị của 2 cell trước khi nhấn enter đề thực hiện.Mọi người giúp đỡ mình cái này nhe.

Mọi người kiểm tra ngay sheet INPUT Sheet. Mình muốn so sánh giá trị của cells(5,3) và Cột(E9:E65536)

Thanks all.

hoanglocphat · 2/2/13

hoanglocphat đã viết:
Các bạn cho mình hỏi, cách clear format các màu tô số liệu
Trong File mình có nhiều màu tô số liệu ví dụ màu nâu (.Font.ColorIndex = 13) màu đỏ (.Font.ColorIndex = 3) ...
Bây giờ mình muốn xóa hết các màu chỉ giữ lại màu nâu ? thì code viết như thế nào?
cảm ơn các bạn

Bài này sao không có ai giúp mình nhỉ, chẳng lẻ mình giải thích không ai hiểu!!!!
Giờ trong khối A1: B100, muốn giữ màu nâu, còn các màu còn lại thì clear hết, đã record macro rồi, nhưng xóa hết thì biết, còn giữ lại 1 màu như trên thì hổng biết, mong sự giúp đỡ của các bạn!

Quang_Hải · 2/2/13

hoanglocphat đã viết:
Bài này sao không có ai giúp mình nhỉ, chẳng lẻ mình giải thích không ai hiểu!!!!
Giờ trong khối A1: B100, muốn giữ màu nâu, còn các màu còn lại thì clear hết, đã record macro rồi, nhưng xóa hết thì biết, còn giữ lại 1 màu như trên thì hổng biết, mong sự giúp đỡ của các bạn!

Bạn thử code này

PHP:

Sub xoa_format()
Dim cell
For Each cell In [A1:B100]
   If cell.Font.ColorIndex <> 13 Then
      cell.Font.ColorIndex = xlColorIndexAutomatic
   End If
Next
End Sub

sangcd779 · 4/2/13

mong các bác xem giúp em đây là lỗi gì và sửa như thế nào ạ!

Em viết rồi cho chạy nhưng mà lúc nào nó cũng báo lỗi:
"End if without block if"

''Tinh toan

For i = nBG To nEND
'Tinh DeltaLtong
DeltaLtong(i) = K * P(i) * Lcoc / EA
SDmin(i) = DeltaLtong(i)
Thudan:
Qfthuc(i) = 0
Smui(i) = (SD(i) - DeltaLtong(i)) * 1000
DeltaLi(i) = (SD(i) - Smui(i) / 2) * 1000
For j = 1 To nlop
'Tinh suc khang ben tung lop
Wi(i, j) = A(j) * Math.Log(DeltaLi(i)) + B(j)
If Wi(i, j) < 0 Then SD(i) = SD(i) + DeltaSD
GoTo Thudan
End If
Fithuc(i, j) = Wi(i, j) * L(j) / 10
Qfthuc(i) = Qfthuc(i) + Fithuc(i, j) * Dcoc * PI
Next
'Tinh suc khang mui
Wmui(i) = C(nlop) * Math.Log(Smui(i)) + D(nlop)
If Wmui(i) < 0 Then SD(i) = SD(i) + DeltaSD
GoTo Thudan
End If
Qpthuc(i) = PI * Dcoc ^ 2 / 4 * Wmui(i) / 10
Qthuc(i) = Qfthuc(i) + Qpthuc(i)
DeltaQP(i) = Qthuc(i) - P(i)
'Kiem tra DeltaQP(i)
If DeltaQP(i) = 0 Then
GoTo Thoat
Else
If DeltaQP(i) > 0 Then
SD(i) = 0
GoTo Thoat
Else
DeltaQP(i) = Abs(DeltaQP(i))

Do
Do While DeltaQP(i) > epxilon
If SD(i) >= SDmax Then
GoTo Thoat
Else
SD(i) = SD(i) + DeltaSD
GoTo Thudan
End If
Loop
Loop Until DeltaQP(i) <= epxilon
End If
End If

Thoat:

aviaiva · 4/2/13

PHP:

For i = nBG To nEND
'Tinh DeltaLtong
DeltaLtong(i) = K * P(i) * Lcoc / EA
SDmin(i) = DeltaLtong(i)
Thudan:
Qfthuc(i) = 0
Smui(i) = (SD(i) - DeltaLtong(i)) * 1000
DeltaLi(i) = (SD(i) - Smui(i) / 2) * 1000
For j = 1 To nlop
'Tinh suc khang ben tung lop
Wi(i, j) = A(j) * Math.Log(DeltaLi(i)) + B(j)
If Wi(i, j) < 0 Then SD(i) = SD(i) + DeltaSD
GoTo Thudan
End If
Fithuc(i, j) = Wi(i, j) * L(j) / 10
Qfthuc(i) = Qfthuc(i) + Fithuc(i, j) * Dcoc * PI
Next
'Tinh suc khang mui
Wmui(i) = C(nlop) * Math.Log(Smui(i)) + D(nlop)
If Wmui(i) < 0 Then SD(i) = SD(i) + DeltaSD
GoTo Thudan
End If
Qpthuc(i) = PI * Dcoc ^ 2 / 4 * Wmui(i) / 10
Qthuc(i) = Qfthuc(i) + Qpthuc(i)
DeltaQP(i) = Qthuc(i) - P(i)
'Kiem tra DeltaQP(i)
If DeltaQP(i) = 0 Then
GoTo Thoat
Else
If DeltaQP(i) > 0 Then
SD(i) = 0
GoTo Thoat
Else
DeltaQP(i) = Abs(DeltaQP(i))

Do
Do While DeltaQP(i) > epxilon
If SD(i) >= SDmax Then
GoTo Thoat
Else
SD(i) = SD(i) + DeltaSD
GoTo Thudan
End If
Loop
Loop Until DeltaQP(i) <= epxilon
End If
End If

Bạn gửi file lên thì dễ xem hơn nhiều

ndu96081631 · 4/2/13

sangcd779 đã viết:
Em viết rồi cho chạy nhưng mà lúc nào nó cũng báo lỗi:
"End if without block if"

Mã:

''Tinh toan If Wi(i, j) < 0 Then SD(i) = SD(i) + DeltaSD GoTo Thudan [COLOR=#ff0000][B]End If[/B][/COLOR] If Wmui(i) < 0 Then SD(i) = SD(i) + DeltaSD GoTo Thudan [COLOR=#ff0000][B]End If[/B][/COLOR] Thoat:

Mấy cái End If màu đỏ là thừa
Cấu trúc If phải thế này mới đúng

Mã:

''Tinh toan
If Wi(i, j) < 0 Then
  SD(i) = SD(i) + DeltaSD
  GoTo Thudan
[COLOR=#ff0000]End If[/COLOR]
    
If Wmui(i) < 0 Then
  SD(i) = SD(i) + DeltaSD
  GoTo Thudan
[COLOR=#ff0000]End If[/COLOR]



Thoat:

sangcd779 · 4/2/13

Wi(i, j) = A(j) * Math.Log(DeltaLi(i)) + B(j)
Em sửa như bác chỉ rồi nhưng ở phần này nó chạy và không nhận đc giá trị nào cả. k biết còn lỗi gì ở câu lệnh này không ạ??
bác xem giúp em với!

ndu96081631 · 4/2/13

sangcd779 đã viết:
Wi(i, j) = A(j) * Math.Log(DeltaLi(i)) + B(j)
Em sửa như bác chỉ rồi nhưng ở phần này nó chạy và không nhận đc giá trị nào cả. k biết còn lỗi gì ở câu lệnh này không ạ??
bác xem giúp em với!

Muốn biết chi tiết còn lỗi nào không thì buộc phải có file đính kèm bạn à!
Tụng kinh bằng băng cassette thế này khó thành chánh quả lắm! Ẹc... Ẹc...

nghiepdung · 5/2/13

Cần các cao thủ giúp đỡ về đoạn code này

Em hơi kém về excel xin các pro giải thích hộ em đoạn code này với , càng chi tiết càng tốt ạ , em xin cảm ơn nhiều nhiều .................

Private Sub ListBox1_Click()
ActiveCell.Value = Sheet1.ListBox1.Value
HideTextBox1
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
loc1
End Sub
Private Sub ListBox2_Click()
ActiveCell.Value = Sheet1.ListBox2.Value
HideTextBox2
End Sub
Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
loc2
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
Application.EnableEvents = False
Dim val As String
Dim rng As Range
If Not Intersect(Target, [b3:b100]) Is Nothing Then
Target.Offset(0, 1).Value = Application.WorksheetFunction.VLookup(Target.Value, Sheet2.Range("Nhap"), 2, 0)
Target.Offset(0, 2).Value = Application.WorksheetFunction.VLookup(Target.Value, Sheet2.Range("Nhap"), 3, 0)
End If

If Not Intersect(Target, [C3:C100]) Is Nothing Then
r = Application.WorksheetFunction.Match(Target.Value, Sheet2.Range("TenSP"), 0)
Target.Offset(0, -1).Value = Application.WorksheetFunction.Index(Sheet2.Range("Mahang"), r)
Target.Offset(0, 1).Value = Application.WorksheetFunction.Index(Sheet2.Range("GiaNhap"), r)

End If

ErrHandler:
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, [b3:b10000]) Is Nothing Then
thaydoi1
Else
HideTextBox1
End If

If Not Intersect(Target, [C3:C10000]) Is Nothing Then
thaydoi2
Else
HideTextBox2
End If

End Sub

matran25251325 · 11/2/13

Bổ sung code tính toán.

sheet MAUCHUAN là sheet dữ liệu. Sau khi tra mã công việc ở sheet TLuong DT (click vào A10 sheet TLuong DT và chọn 1 công việc) thì ở cột P ( cột số lượng) công thức tính toán là P11 = O11 x D10 ; nhưng công thức ở cột P thuờng không đúng khi tra mã hiệu thứ 2. Mong các anh bổ sung đoạn code phần tính toán đó ở sheet TLuong DT ( hoặc công thức, name động). Thường thì sau khi tra mã em toàn dùng thủ công để đánh đúng công thức rồi kéo xuống, nên em muốn sau khi tra mã thì công thức tính ở cột P là chính xác. Em co nhặt được phần bổ sung này nhưng ko đúng:

Tinh so luong:
m = Target.Row
n = Target.Offset(0, -1).End(xlUp).Row
Target.Offset(0, 5) = "=(O" & n & "*D" & m & ",3)"

Em cảm ơn. Thân
http://www.mediafire.com/?6m729co1qp7ec24

ptm0412 · 11/2/13

Nếu m = 5, n = 6 thì "=(O" & n & "*D" & m & ",3)" trở thành:

=(O6*D5,3)

Bạn xem bình thường gõ vào ô cái ấy sẽ ra cái gì

matran25251325 · 11/2/13

Vậy là đúng hay sai nhỉ? //////

Bạn giúp mình chỗ phép tính đó với.

ptm0412 · 11/2/13

matran25251325 đã viết:
Vậy là đúng hay sai nhỉ? Bạn giúp mình chỗ phép tính đó với.

Sai mới phải hỏi, đúng không?
Trong công thức =(O6*D5,3) thiếu cái gì chỉ có bạn biết, chứ ai biết? Thiếu gì thì bạn bổ sung vô.

matran25251325 · 11/2/13

Đoạn code trên mình nhặt của người khác nên mình bít đâu mà sửa. với file mình post lên bạn có cách nào giúp mình với.

ptm0412 · 11/2/13

File của bạn đọc cũng như không ấy. Sheet dùng để vlookup thì lại xóa đi.
Bạn muốn gì ở câu lệnh Target.Offset(0, 5) = "=(O" & n & "*D" & m & ",3)"?
Bạn đang làm mất thì giờ của chính bạn, nếu không nói rõ yêu cầu.

matran25251325 · 12/2/13

ý mình là ở cột số lượng ( cột P) sheet TLuong thì công thức tính số lượng là không đúng sau khi tra mã hiệu. Ví dụ mã hiệu AE.11313 sau khi tra thì có:
số lượng xi măng: P11 = o11xD10
Cát: P12=O12xD10
Đá dăm: P13=O13xD10
.....
Mã hiệu AE.243 sau khi tra thì có:
số lượng xi măng: P17 = o17xD10 (D16 mới đúng)
Cát: P18 = O18xD10 (D16 mới đúng)
Đá dăm: P19 = O19xD10 (D16 mới đúng)
Bạn Right-click cột A22 và chọn 1 công việc tiếp theo thì bạn thấy công thức la sai.
Còn cột Q ko ảnh hưởng gì

viehoai · 12/2/13

matran25251325 đã viết:
ý mình là ở cột số lượng ( cột P) sheet TLuong thì công thức tính số lượng là không đúng sau khi tra mã hiệu. Ví dụ mã hiệu AE.11313 sau khi tra thì có:
số lượng xi măng: P11 = o11xD10
Cát: P12=O12xD10
Đá dăm: P13=O13xD10
.....
Mã hiệu AE.243 sau khi tra thì có:
số lượng xi măng: P17 = o17xD10 (D16 mới đúng)
Cát: P18 = O18xD10 (D16 mới đúng)
Đá dăm: P19 = O19xD10 (D16 mới đúng)
Bạn Right-click cột A22 và chọn 1 công việc tiếp theo thì bạn thấy công thức la sai.
Còn cột Q ko ảnh hưởng gì

Công thức bạn sai bởi vì ngay từ sheet "MAUCHUAN" công thức ấy chưa chẩn làm sao đúng được. Bạn sửa các công thức cột P sheet "MAUCHUAN" cho đúng, chú ý không có dấu $ trong công thức, nếu không vẫn sai

ptm0412 · 12/2/13

Thêm đoạn này vào sự kiện worksheet_Change:

PHP:

            For Each Cll In Sheet1.Range("P" & Target.Row + 1).Resize(iNhay - 1, 1)
                Cll.Value = "=D" & Target.Row & "*O" & Cll.Row
            Next

Sau khi xóa code thừa, nguyên code sẽ là:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Vung As Range, iHang As Long, iNhay As Long
    Dim Cll As Range
    If Not Intersect(Target, [A4:A65536]) Is Nothing Then
        If Target.Count = 1 Then
            Set Vung = Sheets("MAUCHUAN").Range(Sheets("MAUCHUAN").[B10], _
            Sheets("MAUCHUAN").[B10000].End(xlUp)).Offset(, -1)
            iHang = Application.WorksheetFunction.Match(Target, Vung, 0)
            iNhay = Vung(iHang).End(xlDown).Row - Vung(iHang).Row
            Vung(iHang).Offset(, 1).Resize(iNhay, 17).Copy Target.Offset(, 1)
            For Each Cll In Sheet1.Range("P" & Target.Row + 1).Resize(iNhay - 1, 1)
                Cll.Value = "=D" & Target.Row & "*O" & Cll.Row
            Next
        End If
    End If
End Sub

matran25251325 · 12/2/13

viehoai đã viết:
Công thức bạn sai bởi vì ngay từ sheet "MAUCHUAN" công thức ấy chưa chẩn làm sao đúng được. Bạn sửa các công thức cột P sheet "MAUCHUAN" cho đúng, chú ý không có dấu $ trong công thức, nếu không vẫn sai

Hic sheet MAUCHUAN mấy trăm mã hiệu, nếu làm thủ công thì .......Đuối

matran25251325 · 12/2/13

ptm0412 đã viết:

Thêm đoạn này vào sự kiện worksheet_Change:

PHP:

            For Each Cll In Sheet1.Range("P" & Target.Row + 1).Resize(iNhay - 1, 1)
                Cll.Value = "=D" & Target.Row & "*O" & Cll.Row
            Next

Sau khi xóa code thừa, nguyên code sẽ là:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Vung As Range, iHang As Long, iNhay As Long
    Dim Cll As Range
    If Not Intersect(Target, [A4:A65536]) Is Nothing Then
        If Target.Count = 1 Then
            Set Vung = Sheets("MAUCHUAN").Range(Sheets("MAUCHUAN").[B10], _
            Sheets("MAUCHUAN").[B10000].End(xlUp)).Offset(, -1)
            iHang = Application.WorksheetFunction.Match(Target, Vung, 0)
            iNhay = Vung(iHang).End(xlDown).Row - Vung(iHang).Row
            Vung(iHang).Offset(, 1).Resize(iNhay, 17).Copy Target.Offset(, 1)
            For Each Cll In Sheet1.Range("P" & Target.Row + 1).Resize(iNhay - 1, 1)
                Cll.Value = "=D" & Target.Row & "*O" & Cll.Row
            Next
        End If
    End If
End Sub

Code gần đúng rồi, nhưng vẫn còn 2 vướng mắc:
- Mã hiệu có máy thi công và bù nguyên liệu thì công thức ở cột P (phần tô đỏ) sẽ trống, còn phần bù nguyên liệu thì bù nguyên liệu máy nào sẽ = định mức máy đó (P21 = O16, P22=O17).
- Code có phần lỗi là các mã hiệu ở sheet MAUCHUAN (sheet nguồn) có các hàng kề nhau thì nếu tra 1 mã hiêu thì các mã hiệu đó sẽ nhảy theo, do đó ở sheet MAUCHUAN mình toàn insert 1 hàng trống.
http://www.mediafire.com/?9x5rbqw78c7igud

ptm0412 · 12/2/13

Gần đúng là thế nào, bạn hỏi cái gì tôi sửa code chỗ đó, tự nhiêu đẻ ra yêu cầu mới.
1. Máy thi công & bù nguyên liệu: Bạn cho 1 cái if vào
2. Bạn chèn dòng trống rồi thì phải đúng. Không chèn mới sai.

matran25251325 · 12/2/13

Đã giúp thì bạn giúp cho chót luôn đi, mình thử nhiều cách mà toàn lỗi chỗ Máy thi công & bù nguyên liệu, Còn chỗ dòng trống có cách nào không chèn vẫn chạy bình thường không?

ptm0412 · 12/2/13

Xem file, thì cách tốt nhất là sheet mẫu chuẩn bạn làm cho chuẩn đúng nghĩa chuẩn. Rồi copy qua là xong chuyện.

Còn vụ 1 dòng không chèn thì sửa code như sau:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Vung As Range, iHang As Long, iNhay As Long
    Dim Cll As Range
    If Not Intersect(Target, [A4:A65536]) Is Nothing Then
        If Target.Count = 1 Then
            Set Vung = Sheets("MAUCHUAN").Range(Sheets("MAUCHUAN").[B10], _
            Sheets("MAUCHUAN").[B10000].End(xlUp)).Offset(, -1)
            iHang = Application.WorksheetFunction.Match(Target, Vung, 0)
            iNhay = IIf(Vung(iHang + 1) <> "", 1, Vung(iHang).End(xlDown).Row - Vung(iHang).Row)
            Vung(iHang).Offset(, 1).Resize(iNhay, 17).Copy Target.Offset(, 1)
            If iNhay > 1 Then
                For Each Cll In Sheet1.Range("P" & Target.Row + 1).Resize(iNhay - 1, 1)
                    Cll.Value = "=D" & Target.Row & "*O" & Cll.Row
                Next
            End If
        End If
    End If
End Sub

Tuy nhiên cách tốt hơn, là việc copy này đưa luôn vào code nhấn nút chọn của form, khỏi bắt lỗi lôi thôi:

PHP:

Private Sub CommandButton2_Click()
With Selection
   .Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 0)
   .Offset(, 1).Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 1)
   .Offset(, 2).Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 2)
    Dim Vung As Range, iHang As Long, iNhay As Long
    Dim Cll As Range
        Set Vung = Sheets("MAUCHUAN").Range(Sheets("MAUCHUAN").[B10], _
        Sheets("MAUCHUAN").[B10000].End(xlUp)).Offset(, -1)
        iHang = Application.WorksheetFunction.Match(.Value, Vung, 0)
        iNhay = IIf(Vung(iHang + 1) <> "", 1, Vung(iHang).End(xlDown).Row - Vung(iHang).Row)
        Vung(iHang).Offset(, 1).Resize(iNhay, 17).Copy .Offset(, 1)
        If iNhay > 1 Then
            For Each Cll In Sheet1.Range("P" & .Row + 1).Resize(iNhay - 1, 1)
                Cll.Value = "=D" & .Row & "*O" & Cll.Row
            Next
        End If
End With
End Sub

pdhuyxn2 · 13/2/13

Nhờ các Bác giải thích hộ em đoạn code trên

Option Explicit

Private Function SwapChars(chars As String) As String

Dim i As Integer
Dim r As String
For i = Len(chars) To 1 Step -1
r = r & Mid(chars, i, 1)
Next
SwapChars = r

End Function

Private Function SwapStr(str As String, GroupNum As Integer, Code As Boolean) As String

'swap each group chars in string
Dim i As Integer, txt As String: txt = str
Dim chars As String
Dim r As String
Dim k As Integer

If Code Then k = 1 Else k = -1

Do While Len(txt) >= GroupNum
chars = Mid(txt, 1, GroupNum)
r = r & SwapChars(chars)
txt = Right(txt, Len(txt) - GroupNum)
Loop

r = r & SwapChars(txt)
SwapStr = r

End Function

Private Function Coding(txt As String, Key As String) As String

Dim r As String: r = txt
Dim i As Integer, N As Integer
For i = 1 To Len(Key)
N = CInt(Mid(Key, i, 1))
r = SwapStr(r, N, True)
Next
Coding = r
End Function

Private Function DeCoding(txt As String, Key As String) As String

Dim r As String: r = txt

Dim i As Integer, N As Integer
For i = Len(Key) To 1 Step -1
N = CInt(Mid(Key, i, 1))
r = SwapStr(r, N, False)
Next
DeCoding = r
End Function
'
'Code for register
'
Private Function Code1(ByVal s As String) As String
Dim i As Integer
Dim tg As String
Dim ch As String * 1
For i = 1 To Len(s)
ch = Mid(s, i, 1)
tg = tg & Asc(ch) - i * 2
If i Mod 2 = 0 And i < Len(s) Then tg = tg & "-"
Next
Code1 = tg
End Function

Private Function Decode1(ByVal s As String) As String
On Error Resume Next
Dim i As Integer
Dim tg As String
Dim ch As String
i = 1
Do While i < Len(s)
If i Mod 5 = 0 And i < Len(s) Then i = i + 1
ch = Mid(s, i, 2)
tg = tg & Chr(CInt(ch) + (Len(tg) + 1) * 2)
i = i + 2
Loop
Decode1 = tg
End Function

Public Function CheckPLSCopyRight() As Boolean

CheckPLSCopyRight = True

Dim Sys32Dir As String: Sys32Dir = WindowsDirectory & "\system32\"

Dim RegFile As String: RegFile = "userpls.dll"

Dim m_a_c As String
m_a_c = Getm_a_cAddress()
m_a_c = Right(m_a_c, Len(m_a_c) - 2)
m_a_c = Coding(m_a_c, "94323")
'Kreg = vbNull

Dim Key As String

If Dir(Sys32Dir & RegFile) = "" Then
'
'Show Registration form
'
With FrmReg
.TxtUserID = m_a_c
.Show 1
Key = .TxtRegCode.Text
Key = Decode1(Key)
Key = DeCoding(Key, "94323")
If Key = m_a_c Then
'
'Create File
'
Open Sys32Dir & RegFile For Output As #1
Print #1, .TxtRegCode.Text
Close #1
MsgBox "Thank you for registration.", vbInformation
Else
MsgBox "Invalid RegKey!", vbCritical
End If
End With
End If
'
'Test registration
'
If Dir(Sys32Dir & RegFile) = "" Then Exit Function

Dim FDate As Date
FDate = FileDate(Sys32Dir & RegFile)
'
'Expired date = 365 = 12 month
'
If ((Now - FDate) > 365 * 5) Or (Now > CDate("30 March 2015")) Then
MsgBox "Can't run macro, Acad is busy. Wait for a moment and try again.", vbCritical
'Kill Sys32Dir & RegFile
'Empty file
Open Sys32Dir & RegFile For Output As #1
Print #1, ""
Close #1
Exit Function
End If
'
'Open file for checking RegKey
'
Open Sys32Dir & RegFile For Input As #1
Input #1, Key
Close #1
Key = Decode1(Key)
Key = DeCoding(Key, "94323")

'If Key <> m_a_c Then
' MsgBox "Can't run macro, Acad is busy. Wait for a moment and try again.", vbCritical
' Exit Function
'End If

MyPrompt "Check AutoCad OK"
CheckPLSCopyRight = True
End Function

Private Function FileDate(Fname As String) As Date

Dim FS As Object, F As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Set F = FS.GetFile(Fname)
FileDate = F.DateCreated
Set FS = Nothing

End Function

Public Function Getcode(m_a_c As String) As String

Getcode = Coding(m_a_c, "94323")
Getcode = Code1(Getcode)

End Function

ChanhTQ@ · 14/2/13

Chúng ta sẽ lần lượt chinh fục từng Anh một nhe bạn:

(1)

PHP:

Private Function SwapChars(chars As String) As String

 Dim i As Integer
 Dim r As String
 For i = Len(chars) To 1 Step -1
    r = r & Mid(chars, i, 1)
 Next
 SwapChars = r
End Function

Hàm này có công dụng đão các ký tự trong chuỗi;
Như ta cung cấp cho nó "GPE.COM", nó sẽ trả về "MOC.EPG"

(2)

PHP:

Private Function SwapStr(str As String, GroupNum As Integer, Code As Boolean) As String
'swap each group chars in string'
1 Dim i As Integer,  k As Integer
 Dim chars As String, txt As String, r As String

3 txt = str
 If Code Then k = 1 Else k = -1

5 Do While Len(txt) >= GroupNum
    chars = Mid(txt, 1, GroupNum)
7    r = r & SwapChars(chars)
    txt = Right(txt, Len(txt) - GroupNum)
9 Loop
 r = r & SwapChars(txt)
11 SwapStr = r

End Function

Hàm thứ 2 này thực hiện 3 việc;
1: (Dòng lệnh 6) Cắt chuỗi được cung cấp cho hàm theo nhóm có độ dài theo tham biến GroupNum
2: (Dòng lệnh 7) Gọi hàm đầu để đão nhóm kí tự vừa cắt
3: (Dòng lệnh 8) Làm động tác như dòng lệnh 6, nhưng với nhóm các ký tự cuối còn lại

Tuy nhiên, theo mình thì vòng lặp này tiềm ẩn nhiều nguy cơ một khi GroupNum nhớn hơn nhiều so với độ dài chuỗi đưa cho hàm
(Chúng ta cần bẩy lỗi cho hàm)

matran25251325 · 14/2/13

Đã chuyển từ RightCLick sang DoubleClick để làm. TK mọi người.

pdhuyxn2 · 15/2/13

Nhờ các Bác Giải thích giùm em đoạn còn lại

pdhuyxn2 · 15/2/13

Option Explicit

Private Function SwapChars(chars As String) As String

Dim i As Integer
Dim r As String
For i = Len(chars) To 1 Step -1
r = r & Mid(chars, i, 1)
Next
SwapChars = r

End Function

Private Function SwapStr(str As String, GroupNum As Integer, Code As Boolean) As String

'swap each group chars in string
Dim i As Integer, txt As String: txt = str
Dim chars As String
Dim r As String
Dim k As Integer

If Code Then k = 1 Else k = -1

Do While Len(txt) >= GroupNum
chars = Mid(txt, 1, GroupNum)
r = r & SwapChars(chars)
txt = Right(txt, Len(txt) - GroupNum)
Loop

r = r & SwapChars(txt)
SwapStr = r

End Function

Private Function Coding(txt As String, Key As String) As String

Dim r As String: r = txt
Dim i As Integer, N As Integer
For i = 1 To Len(Key)
N = CInt(Mid(Key, i, 1))
r = SwapStr(r, N, True)
Next
Coding = r
End Function

Private Function DeCoding(txt As String, Key As String) As String

Dim r As String: r = txt

Dim i As Integer, N As Integer
For i = Len(Key) To 1 Step -1
N = CInt(Mid(Key, i, 1))
r = SwapStr(r, N, False)
Next
DeCoding = r
End Function
'
'Code for register
'
Private Function Code1(ByVal s As String) As String
Dim i As Integer
Dim tg As String
Dim ch As String * 1
For i = 1 To Len(s)
ch = Mid(s, i, 1)
tg = tg & Asc(ch) - i * 2
If i Mod 2 = 0 And i < Len(s) Then tg = tg & "-"
Next
Code1 = tg
End Function

Private Function Decode1(ByVal s As String) As String
On Error Resume Next
Dim i As Integer
Dim tg As String
Dim ch As String
i = 1
Do While i < Len(s)
If i Mod 5 = 0 And i < Len(s) Then i = i + 1
ch = Mid(s, i, 2)
tg = tg & Chr(CInt(ch) + (Len(tg) + 1) * 2)
i = i + 2
Loop
Decode1 = tg
End Function

Public Function CheckPLSCopyRight() As Boolean

CheckPLSCopyRight = True

Dim Sys32Dir As String: Sys32Dir = WindowsDirectory & "\system32\"

Dim RegFile As String: RegFile = "userpls.dll"

Dim m_a_c As String
m_a_c = Getm_a_cAddress()
m_a_c = Right(m_a_c, Len(m_a_c) - 2)
m_a_c = Coding(m_a_c, "94323")
'Kreg = vbNull

Dim Key As String

If Dir(Sys32Dir & RegFile) = "" Then
'
'Show Registration form
'
With FrmReg
.TxtUserID = m_a_c
.Show 1
Key = .TxtRegCode.Text
Key = Decode1(Key)
Key = DeCoding(Key, "94323")
If Key = m_a_c Then
'
'Create File
'
Open Sys32Dir & RegFile For Output As #1
Print #1, .TxtRegCode.Text
Close #1
MsgBox "Thank you for registration.", vbInformation
Else
MsgBox "Invalid RegKey!", vbCritical
End If
End With
End If
'
'Test registration
'
If Dir(Sys32Dir & RegFile) = "" Then Exit Function

Dim FDate As Date
FDate = FileDate(Sys32Dir & RegFile)
'
'Expired date = 365 = 12 month
'
If ((Now - FDate) > 365 * 5) Or (Now > CDate("30 March 2015")) Then
MsgBox "Can't run macro, Acad is busy. Wait for a moment and try again.", vbCritical
'Kill Sys32Dir & RegFile
'Empty file
Open Sys32Dir & RegFile For Output As #1
Print #1, ""
Close #1
Exit Function
End If
'
'Open file for checking RegKey
'
Open Sys32Dir & RegFile For Input As #1
Input #1, Key
Close #1
Key = Decode1(Key)
Key = DeCoding(Key, "94323")

'If Key <> m_a_c Then
' MsgBox "Can't run macro, Acad is busy. Wait for a moment and try again.", vbCritical
' Exit Function
'End If

MyPrompt "Check AutoCad OK"
CheckPLSCopyRight = True
End Function

Private Function FileDate(Fname As String) As Date

Dim FS As Object, F As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Set F = FS.GetFile(Fname)
FileDate = F.DateCreated
Set FS = Nothing

End Function

Public Function Getcode(m_a_c As String) As String

Getcode = Coding(m_a_c, "94323")
Getcode = Code1(Getcode)

End Function

SA_DQ · 15/2/13

Câu 3

PHP:

Private Function DeCoding(Txt As String, Key As String) As String
 Dim R As String
 Dim i As Integer, N As Integer
3 R = Txt
 For i = Len(Key) To 1 Step -1
5    N = CInt(Mid(Key, i, 1))
    R = SwapStr(R, N, False)
7 Next
 DeCoding = R
End Function

Trước khi đi vô giải thích hàm tự tạo này làm gì; Mình xin fép trích dịch hàm sang ngôn ngữ Việt, như sau:

Dòng 1 & 2: Khai báo các biến cần dùng trong hàm;
Dòng 3: Gán tham biến Txt vô biến kiểu chuỗi vừa khai báo;
Dòng 4: Thiết lập vòng lặp giảm dần với bước giảm -1 từ chiều dài của tham biến Key đến 1
Vòng lặp kết thúc tại dòng lệnh 7
Dòng 5: Dùng hàm Mid() cắt lấy 1 kí tự theo tham số của vòng lặp & chuyển ký tự này thành ký số.
Dòng 6: Dùng hàm tự tạo SwapStr(R, N, False) để xử lý chuỗi
Dòng 8: Kết quả xử lý được trả về & kết thúc hàm.

Tuy nhiên, đối chiếu với quyển "VBA trong EXCEL, cải thiện & tăng tốc" của Fạm Khắc Duy vừa fát hành, thì hàm thứ ba này, cũng như hàm thứ hai vừa gọi tiềm ẩn rất nhiều bất trắc.
Những điều đó mình rất muốn dừng lại thật lâu để fân tích với bạn.
Đó là dòng lệnh 5.
Dòng này làm 2 việc, việc thứ nhất, là cắt 1 ký tự trong chuỗi tham biến 'Key' & việc thứ hai là biến ký tự này thành ký số;
[thongbao]
Nhưng quá trình thứ 2 này sẽ vấp ngã, một khi người dùng không nhập hoàn toàn là chuỗi các ký số, như "1254", mà là "3214.", hay ngay cả toàn là ký số, như "12091" thì hàm sẽ fá sản![/thongbao]

Good-Luck · 15/2/13

HYen17 đã viết:

PHP:

Tuy nhiên, đối chiếu với quyển "VBA trong EXCEL, cải thiện & tăng tốc" của [COLOR=#ff0000]Fạm Khắc Duy [/COLOR]vừa fát hành, thì hàm thứ ba này, cũng như hàm thứ hai vừa gọi tiềm ẩn rất nhiều bất trắc.[/QUOTE]
thân chao All Member ([COLOR=#0000cd]đặt biệt là Tác Giả "Kyo" của Cuốn Sách "VBA trong EXCEL, cải thiện & tăng tốc" [/COLOR]) !
mình xin đặt câu hỏi ngoài lề chút
cảm phiền cho hỏi cuốn sách của tác giả Kyo "Phạm khắc Duy" vừa phát hành có bán ngoài thị trường ko? và làm thế nào để sở hữu được nó, mình rất mong được sở hữu và tìm hiểu thêm về VBA trong excel , Thanks

[COLOR=#0000cd]cũng nhớ là [/COLOR][COLOR=#ff0000]Nguyễn khắc Duy[/COLOR][COLOR=#0000cd] nhưng thấy LãoThành viên HYen17 gọi thế nên hùa theo, Sorry[/COLOR]

kyo · 15/2/13

Good-Luck đã viết:
thân chao All Member (đặt biệt là Tác Giả "Kyo" của Cuốn Sách "VBA trong EXCEL, cải thiện & tăng tốc" ) !
mình xin đặt câu hỏi ngoài lề chút
cảm phiền cho hỏi cuốn sách của tác giả Kyo "Phạm khắc Duy" vừa phát hành có bán ngoài thị trường ko? và làm thế nào để sở hữu được nó, mình rất mong được sở hữu và tìm hiểu thêm về VBA trong excel , Thanks

Cho kyo đính chính lại tên kyo là Nguyễn Khắc Duy.
Qua Tết GPE mới chính thức phát hành bạn à. Cũng sắp rồi @$@!^%

Kyo.

pdhuyxn2 · 16/2/13

Các Bác giải thích cho em đoạn code quan trọng này nhé

Public Function CheckPLSCopyRight() As Boolean

CheckPLSCopyRight = True

Dim Sys32Dir As String: Sys32Dir = WindowsDirectory & "\system32\"

Dim RegFile As String: RegFile = "userpls.dll"

Dim m_a_c As String
m_a_c = Getm_a_cAddress()
m_a_c = Right(m_a_c, Len(m_a_c) - 2)
m_a_c = Coding(m_a_c, "94323")
'Kreg = vbNull

Dim Key As String

If Dir(Sys32Dir & RegFile) = "" Then
'
'Show Registration form
'
With FrmReg
.TxtUserID = m_a_c
.Show 1
Key = .TxtRegCode.Text
Key = Decode1(Key)
Key = DeCoding(Key, "94323")
If Key = m_a_c Then
'
'Create File
'
Open Sys32Dir & RegFile For Output As #1
Print #1, .TxtRegCode.Text
Close #1
MsgBox "Thank you for registration.", vbInformation
Else
MsgBox "Invalid RegKey!", vbCritical
End If
End With
End If
'
'Test registration
'
If Dir(Sys32Dir & RegFile) = "" Then Exit Function

Dim FDate As Date
FDate = FileDate(Sys32Dir & RegFile)
'
'Expired date = 365 = 12 month
'
If ((Now - FDate) > 365 * 5) Or (Now > CDate("30 March 2015")) Then
MsgBox "Can't run macro, Acad is busy. Wait for a moment and try again.", vbCritical
'Kill Sys32Dir & RegFile
'Empty file
Open Sys32Dir & RegFile For Output As #1
Print #1, ""
Close #1
Exit Function
End If
'
'Open file for checking RegKey
'
Open Sys32Dir & RegFile For Input As #1
Input #1, Key
Close #1
Key = Decode1(Key)
Key = DeCoding(Key, "94323")

'If Key <> m_a_c Then
' MsgBox "Can't run macro, Acad is busy. Wait for a moment and try again.", vbCritical
' Exit Function
'End If

MyPrompt "Check AutoCad OK"
CheckPLSCopyRight = True
End Function

Private Function FileDate(Fname As String) As Date

Dim FS As Object, F As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Set F = FS.GetFile(Fname)
FileDate = F.DateCreated
Set FS = Nothing

End Function

Public Function Getcode(m_a_c As String) As String

Getcode = Coding(m_a_c, "94323")
Getcode = Code1(Getcode)

End Function

nghiepdung · 17/2/13

Em hơi kém về excel xin các pro giải thích hộ em đoạn code này với , càng chi tiết càng tốt ạ , em xin cảm ơn nhiều nhiều .................

Private Sub ListBox1_Click()
ActiveCell.Value = Sheet1.ListBox1.Value
HideTextBox1
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
loc1
End Sub
Private Sub ListBox2_Click()
ActiveCell.Value = Sheet1.ListBox2.Value
HideTextBox2
End Sub
Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
loc2
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
Application.EnableEvents = False
Dim val As String
Dim rng As Range
If Not Intersect(Target, [b3:b100]) Is Nothing Then
Target.Offset(0, 1).Value = Application.WorksheetFunction.VLookup(Target.Value, Sheet2.Range("Nhap"), 2, 0)
Target.Offset(0, 2).Value = Application.WorksheetFunction.VLookup(Target.Value, Sheet2.Range("Nhap"), 3, 0)
End If

If Not Intersect(Target, [C3:C100]) Is Nothing Then
r = Application.WorksheetFunction.Match(Target.Value, Sheet2.Range("TenSP"), 0)
Target.Offset(0, -1).Value = Application.WorksheetFunction.Index(Sheet2.Range("Mahang"), r)
Target.Offset(0, 1).Value = Application.WorksheetFunction.Index(Sheet2.Range("GiaNhap"), r)

End If

ErrHandler:
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, [b3:b10000]) Is Nothing Then
thaydoi1
Else
HideTextBox1
End If

If Not Intersect(Target, [C3:C10000]) Is Nothing Then
thaydoi2
Else
HideTextBox2
End If

End Sub

haitramy · 20/2/13

đoạn codec của e không chạy được, mọi người xem giúp e với!

Private Sub Worksheet_Change2(ByVal target As Range)
Dim rng As Range
Set rng = Range("D")
If rng.Delete Then
rng.Offset(, 1).Resize(, 15).Clear
End If
End Sub

Quang_Hải · 20/2/13

haitramy đã viết:
đoạn codec của e không chạy được, mọi người xem giúp e với!

Đoạn If rng.Delete Then là cái quỷ gì vậy, làm sao chạy được. Muốn edit cũng chẳng ai biết đường mà sửa lại cho bạn

Làm gì có chuyện sửa thành Change2 chứ. Nếu chạy được mình sẽ ngủ mở mắt như Trương Phi

Hoàng Trọng Nghĩa · 20/2/13

quanghai1969 đã viết:
Đoạn If rng.Delete Then là cái quỷ gì vậy, làm sao chạy được. Muốn edit cũng chẳng ai biết đường mà sửa lại cho bạn

Nó cũng giống như vầy nè, nói thì dễ nhưng cụ thể trong code thì khó, nếu delete cột D thì cột nào đó sẽ clear (có thể những công thức sẽ cho giá trị REF). Vấn đề là bằng sự kiện gì để nhận biết cột D bị delete!!!

Ba Tê · 20/2/13

haitramy đã viết:
đoạn codec của e không chạy được, mọi người xem giúp e với!

Hiểu thí thí thì cũng làm thí thí, hên xui thôi.

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cll As Range
If Target.Column = 4 Then
    For Each Cll In Target
        If Cll.Value = "" Then
            Cll.Offset(, 1).Resize(, 15).ClearContents
        End If
    Next
End If
End Sub

Hoàng Trọng Nghĩa · 20/2/13

Ba Tê đã viết:
Hiểu thí thí thì cũng làm thí thí, hên xui thôi.

PHP:

Private Sub Worksheet_Change(ByVal Target As Range) Dim Cll As Range If Target.Column = 4 Then For Each Cll In Target If Cll.Value = "" Then Cll.Offset(, 1).Resize(, 15).ClearContents End If Next End If End Sub

Thật sự mà nói thì khi DELETE cột (không phải CLEAR) thì cột sau dồn lên cột trước, như vậy CỘT CẬN CỘT BỊ XÓA SẼ TRỞ THÀNH CHÍNH NÓ!

Vì thế ta khó xác định được sự kiện nào cho phải!

Hoàng Trọng Nghĩa · 20/2/13

haitramy đã viết:
đoạn codec của e không chạy được, mọi người xem giúp e với!

Tôi không thể làm được sự kiện DELETE, nhưng tôi nghĩ chúng ta nên có 1 nút lệnh để xóa cột thì sẽ tốt hơn!

Mã:

Sub Macro1()
    If MsgBox("Ban co thuc su muon xoa cot D hay khong?", vbQuestion + vbYesNo, "THÔNG BÁO") = vbYes Then
        Sheet1.Columns("D:D").Delete Shift:=xlToLeft
        Sheet1.Columns("D:D").Resize(, 14).Clear
    End If
End Sub

haitramy · 20/2/13

quanghai1969 đã viết:
Đoạn If rng.Delete Then là cái quỷ gì vậy, làm sao chạy được. Muốn edit cũng chẳng ai biết đường mà sửa lại cho bạn

Làm gì có chuyện sửa thành Change2 chứ. Nếu chạy được mình sẽ ngủ mở mắt như Trương Phi

hahaha; em mơi "biết lật" trong thế giới VBA thôi bác ơi, đọc cũng nhiều nhưng không tự viết được nên mạo mụi "viết đại" để các bác sửa rồi tự rút kinh nghiệm như vậy sẽ nhớ lâu hơn; cảm ơn bác!

Hiểu thí thí thì cũng làm thí thí, hên xui thôi.

anh cho em hỏi trong một sheet1 mà có hai đoạn codec Private Sub Worksheet_Change(ByVal Target As Range) ...End sub chạy hai nội dung khác nhau được không (thấy "máy bảo" không được nhưng không biết tại sao), cái Change2 của em ở trên cũng là vậy.hihi

Quang_Hải · 20/2/13

haitramy đã viết:
hahaha; em mơi "biết lật" trong thế giới VBA thôi bác ơi, đọc cũng nhiều nhưng không tự viết được nên mạo mụi "viết đại" để các bác sửa rồi tự rút kinh nghiệm như vậy sẽ nhớ lâu hơn; cảm ơn bác!

Bạn cần kết quả thê nào thì cứ tung cái file lên đây, nói rõ ràng yêu cầu thì sẽ có code mẫu cho bạn nghiên cứu

Hoàng Trọng Nghĩa · 20/2/13

haitramy đã viết:
anh cho em hỏi trong một sheet1 mà có hai đoạn codec Private Sub Worksheet_Change(ByVal Target As Range) ...End sub chạy hai nội dung khác nhau được không (thấy "máy bảo" không được nhưng không biết tại sao), cái Change2 của em ở trên cũng là vậy.hihi

Trong sheet, chỉ có 1 sự kiện Change duy nhất mà thôi:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
End sub

Không thể có các sự kiện Change_n nào thêm nữa cả! Nếu có, nó chỉ là những thủ tục bình thường như các sub khác chứ không còn là sub chạy theo sự kiện nữa.

MinhKhai · 21/2/13

Em có đoạn code được hỗ trợ trên diễn đàn

Mã:

Sub Unique()
  With Sheets("TonKho")
    Dim Maxx As Long
    Max1 = Application.WorksheetFunction.Max(Sheets("Nhap").Range("C18:C1100"))
    Sheets("Nhap").[B]Range("D17:D&Max1")[/B].AdvancedFilter 2, , .Range("C5"), True
    Max2 = Application.WorksheetFunction.Max(Sheets("TonKho").Range("C18:C1100"))
[B]   .Range("A6:N&Max2")[/B].Sort .[C6], 1, Header:=0
    End With
End Sub

Mục đích của Code là tạo list duy nhất (không trùng) và sắp xếp lại.
Vấn đề của em là em chỉ muốn vùng dữ liệu khi lọc không trùng (độ dài vùng dữ liệu trước khi lọc) vừa đúng độ dài thực của nó. Tuy nhiên em chưa biết cách ghép vùng kiểu như Range("D17&Max1") và .Range("A6:N&Max2")
Mong các bác chỉ dẫn

Hoàng Trọng Nghĩa · 21/2/13

Tôi không biết vùng dữ liệu của bạn như thế nào, tuy nhiên với cấu trúc: Range("D17&Max1") và .Range("A6:N&Max2")
là sai nha bạn, phải như vầy mới đúng: Range("D17" & Max1) và .Range("A6:N" & Max2)

MinhKhai · 21/2/13

Hoàng Trọng Nghĩa đã viết:
Tôi không biết vùng dữ liệu của bạn như thế nào, tuy nhiên với cấu trúc: Range("D17&Max1") và .Range("A6:N&Max2")
là sai nha bạn, phải như vầy mới đúng: Range("D17" & Max1) và .Range("A6:N" & Max2)

Cảm ơn bác.
GPE có đội phản ứng rất nhanh. hehee
Em chỉ cần có thế. Em đã làm được rồi

MinhKhai · 23/2/13

Em sử dụng lệnh

Mã:

 ActiveSheet.Protect "password"

để khóa sheet nhưng theo mặc định nó khóa tất cả các chức năng trong sheet.
Khi Protect theo cách thủ công (dùng menu của excel) thì có những lựa chọn nào cho khóa, cái nào không (ví dụ khóa sheet nhưng vẫn cho AutoFilter..)
Vậy mong các bác chỉ dẫn các tham số cho mã Protect trên.

Hong.Van · 23/2/13

MinhKhai đã viết:
Em sử dụng lệnh

Mã:

ActiveSheet.Protect "password"

để khóa sheet nhưng theo mặc định nó khóa tất cả các chức năng trong sheet.
Khi Protect theo cách thủ công (dùng menu của excel) thì có những lựa chọn nào cho khóa, cái nào không (ví dụ khóa sheet nhưng vẫn cho AutoFilter..)
Vậy mong các bác chỉ dẫn các tham số cho mã Protect trên.

Bạn thử cái này

Mã:

AllowFiltering:=True

ndu96081631 · 23/2/13

MinhKhai đã viết:
Em sử dụng lệnh

Mã:

ActiveSheet.Protect "password"

để khóa sheet nhưng theo mặc định nó khóa tất cả các chức năng trong sheet.
Khi Protect theo cách thủ công (dùng menu của excel) thì có những lựa chọn nào cho khóa, cái nào không (ví dụ khóa sheet nhưng vẫn cho AutoFilter..)
Vậy mong các bác chỉ dẫn các tham số cho mã Protect trên.

Bạn record macro quá trình protect sheet bằng tay rồi xem code sẽ tự biết

MinhKhai · 23/2/13

Hong.Van đã viết:
Bạn thử cái này

Mã:

AllowFiltering:=True

ndu96081631 đã viết:
Bạn record macro quá trình protect sheet bằng tay rồi xem code sẽ tự biết

Cảm ơn mọi chỉ dẫn. Em đã hiểu và làm được rồi

phuvacgach · 24/2/13

Hàm Match trong VBA

Dear anh chi, Em có thắc mắc này nhờ ac giải thích giúp,
Em dùng hàm match trong 2 trường hợp thì có trường hợp bì lỗi, em không rõ lý do tại sao?

HTML:

Sub test() '' bi loi
Dim t As Long
Dim mydate As Date
mydate = Range("D2") + 1
t = Application.WorksheetFunction.Match(mydate, Range("B2:B14"), 0)
MsgBox t
End Sub


Sub test2() ''khong bi loi
Dim t As Long
Range("D3") = Range("D2") + 1
t = Application.WorksheetFunction.Match(Range("D3"), Range("B2:B14"), 0)
MsgBox t
End Sub

ndu96081631 · 24/2/13

phuvacgach đã viết:
Dear anh chi, Em có thắc mắc này nhờ ac giải thích giúp,
Em dùng hàm match trong 2 trường hợp thì có trường hợp bì lỗi, em không rõ lý do tại sao?

HTML:

Sub test() '' bi loi Dim t As Long Dim mydate As Date mydate = Range("D2") + 1 t = Application.WorksheetFunction.Match(mydate, Range("B2:B14"), 0) MsgBox t End Sub Sub test2() ''khong bi loi Dim t As Long Range("D3") = Range("D2") + 1 t = Application.WorksheetFunction.Match(Range("D3"), Range("B2:B14"), 0) MsgBox t End Sub

Thay vì Dim mydate As Date bạn sửa lại thành Dim mydate As Long xem sao nhé

nobingo_103 · 26/2/13

Code bị lỗi, không biết cách khắc phục

Mới tập tành viết code, viết được cái đoạn này mà sao nó không chạy ra kết quả được!

Mã:

Function Gia_tri_k(B, L, Z) As Single   
 Dim i, j As Integer
        i = B / 2
        j = L / 2
    If Z = 0 Then
        Gia_tri_k = 1
    Else
        Gia_tri_k =(2 / 3.141592654) * ((Atn((i * j) / (Z * Sqr(i * i + j * j + Z * Z))) + (i * j * Z * (i * i + j * j + 2 * Z * Z)) / ((i * i + Z * Z) * (j * j + Z * Z) * (Sqr(i * i + j * j + Z * Z)))))
    End If
End Function

Với Z khác 0 thì kết quả trả ra toàn là bằng 0. Không hiểu bị sai chỗ nào?

Sau đó nhiều lần xoá bớt, chỉ còn đoạn code như bên dưới đây thì phát hiện ra là biến j=0!

Mã:

Function Gia_tri_k(B, L, Z) As Single  
  Dim i, j As Integer
        i = B / 2
        j = L / 2
    If z = 0 Then
        Gia_tri_k = 1
    Else
        Gia_tri_k = j
    End If
End Function

Trong khi biến i thì cho kết quả đúng (Vd: nếu B=1 thì i=0.5, nhưng L=1 thì j=0!!!)

Nhờ mọi người chỉ giúp với bị sai chỗ nào, mới tập làm quen với VB nên không biết bị sai gì!

ndu96081631 · 26/2/13

nobingo_103 đã viết:
Mới tập tành viết code, viết được cái đoạn này mà sao nó không chạy ra kết quả được!

Mã:

Function Gia_tri_k(B, L, Z) As Single Dim i, j As Integer i = B / 2 j = L / 2 If Z = 0 Then Gia_tri_k = 1 Else Gia_tri_k =(2 / 3.141592654) * ((Atn((i * j) / (Z * Sqr(i * i + j * j + Z * Z))) + (i * j * Z * (i * i + j * j + 2 * Z * Z)) / ((i * i + Z * Z) * (j * j + Z * Z) * (Sqr(i * i + j * j + Z * Z))))) End If End Function

Với Z khác 0 thì kết quả trả ra toàn là bằng 0. Không hiểu bị sai chỗ nào?

Sau đó nhiều lần xoá bớt, chỉ còn đoạn code như bên dưới đây thì phát hiện ra là biến j=0!

Mã:

Function Gia_tri_k(B, L, Z) As Single Dim i, j As Integer i = B / 2 j = L / 2 If z = 0 Then Gia_tri_k = 1 Else Gia_tri_k = j End If End Function

Trong khi biến i thì cho kết quả đúng (Vd: nếu B=1 thì i=0.5, nhưng L=1 thì j=0!!!)

Nhờ mọi người chỉ giúp với bị sai chỗ nào, mới tập làm quen với VB nên không biết bị sai gì!

Biến i và j phải khai báo kiểu Double mới được bạn à (Integer nó là số nguyên cơ mà)
Và hàm của bạn cũng phải trả kết quả và kiểu Double mới được

Mã:

Function Gia_tri_k(B, L, Z) As Double
  Dim i As Double, j As Double
  i = B / 2
  j = L / 2
  If Z = 0 Then
    Gia_tri_k = 1
  Else
    Gia_tri_k = j
  End If
End Function

cuong0202 · 26/2/13

em có mấy nút lệnh như sau,,, [học lóm được]
1. Xóa

Mã:

Private Sub cmdxoa_Click()
If DCount("mahang", "danhmuchanghoa", "mahang='" & mahang & "'") > 0 Then
MsgBox " Ma nay da co phat sinh, khong duoc xoa"
ElseIf MsgBox(" Ban that su muon xoa ma nay", vbYesNo + vbQuestion, "Thong Bao") = vbYes Then
DoCmd.SetWarnings False
DoCmd.RunCommand acCmdDeleteRecord
LDM.Requery
DoCmd.GoToRecord , , acLast
End If
End Sub

2.thêm

Mã:

Private Sub cmdthem_Click()
DoCmd.GoToRecord , , acNewRec
mahang.SetFocus
sangmo False
End Sub

3. lưu

Mã:

Private Sub cmdghi_Click()
If IsNull(mahang) = True Then
MsgBox "Vui long nhap ma"
mahang.SetFocus
ElseIf DCount("mahang", "hanghoa", "mahang='" & mahang & "'") = 1 Then
MsgBox " Ma nay da co, Vui long tao ma khac"
mahang.SetFocus
Else
DoCmd.RunCommand acCmdSaveRecord
LDM.Requery
sangmo True
End If
End Sub

4.quay lại

Mã:

Private Sub cmdundo_Click()
If Me.Dirty Then DoCmd.RunCommand acCmdUndo
DoCmd.GoToRecord , , acLast
sangmo True
End Sub

5. đóng .

Mã:

Private Sub cmdthoat_Click()
If MsgBox("Ban that su muon dong cua so dang lam viec", vbYesNo + vbCritical, "Thong Bao") = vbYes Then
DoCmd.Close , , acSaveYes
End If
End Sub

Nhờ mọi người giúp em code của nút 6. sửa

Với lại chỉ em cách,, khi mở form lên người ta chỉ được,, xem thôi,, khi nào bấm vào nút sửa thì mới được sửa
thank mọi người

namkpac · 27/2/13

anh ndu cho em hỏi câu hỏi hồi nãy với; trong 1 ô cell mà có các ký tự như vậy có khi nào nó được mã hoá, có thể đây là một hộp box không anh. cái này lần đầu tiên em gặp, mong anh chỉ giúp. |441,405||0,0|1,0|2,0|3,0|4,0|436,0|437,0|438,0|439,0|440,0|0,1|1,1|2,1|3,1|437,1|438,1|439,1|440,1|0,2|1,2|2,2|438,2|439,2|440,2|0,3|1,3|439,3|440,3|0,4|440,4|0,398|1,398|0,399|1,399|2,399|0,400|1,400|2,400|440,400|0,401|1,401|2,401|3,401|439,401|440,401|0,402|1,402|2,402|3,402|4,402|
|5,402|438,402|439,402|440,402|0,403|1,403|2,403|3,403|4,403|5,403|6,403|437,403|438,403|439,403|440,403|0,404|1,404|2,404|3,404|4,404|5,404|6,404|436,404|437,404|438,404|439,404|440,404|

sangcd779 · 1/3/13

mong các cao thủ giúp em xem lỗi này là lỗi gì với ạ!
http://www.mediafire.com/?ol3z6l9z3xiccd7

ndu96081631 · 1/3/13

sangcd779 đã viết:
mong các cao thủ giúp em xem lỗi này là lỗi gì với ạ!
http://www.mediafire.com/?ol3z6l9z3xiccd7

Hỏi gì kỳ cục vậy bạn? LỖI NÀY là lỗi nào? Cái gì lỗi? File bị lỗi? Code bị lỗi hay là.. bạn bị lỗi?

sangcd779 · 1/3/13

hì, lại gặp bác rồi.
hôm trc tết em có đăng bài nhở mọi người giúp 1 lần rồi nhưng mà vẫn chưa đc bác ạ..
đây là file chứa lỗi hôm trc em đăng lên ở #1328 ấy ạ.
mong bác chỉ giúp. em cứ bấm chạy thì nó báo lỗi. k chạy đc.

ndu96081631 · 1/3/13

sangcd779 đã viết:
hì, lại gặp bác rồi.
hôm trc tết em có đăng bài nhở mọi người giúp 1 lần rồi nhưng mà vẫn chưa đc bác ạ..
đây là file chứa lỗi hôm trc em đăng lên ở #1328 ấy ạ.
mong bác chỉ giúp. em cứ bấm chạy thì nó báo lỗi. k chạy đc.

Cụ thể là BẤM CÁI GÌ CHẠY? Lỗi là lỗi thế nào
File bạn có cả đống code, vậy bạn đang nói đến code nào?

sangcd779 · 1/3/13

ndu96081631 đã viết:
Cụ thể là BẤM CÁI GÌ CHẠY? Lỗi là lỗi thế nào
File bạn có cả đống code, vậy bạn đang nói đến code nào?

bác bấm vào cái hình mũi tên màu hồng có chữ" TÌM GIÁ TRỊ SD" ở sheet "ĐANG LÀM" ấy ạ. thì nó hiện ra lỗi ở trên đoạn code "tinhlunnhieulop" là end if without if.

ndu96081631 · 1/3/13

sangcd779 đã viết:
bác bấm vào cái hình mũi tên màu hồng có chữ" TÌM GIÁ TRỊ SD" ở sheet "ĐANG LÀM" ấy ạ. thì nó hiện ra lỗi ở trên đoạn code "tinhlunnhieulop" là end if without if.

Code này tôi chẳng test được gì. Vì bấm vào nó chạy nãy giờ vẫn chưa ra ---> Treo máy luôn
Để các bạn khác test thử vậy

xuan.nguyen82 · 1/3/13

Thử chạy code của bạn thì máy tính mình đơ luôn. Phải Restart lại máy.

Đọc qua câu hỏi thì bạn thử xem topic dưới đây xem có giúp ích được gì cho bạn không nhé.
Có bác Ndu trả lời trong đó đấy.
http://www.giaiphapexcel.com/forum/showthread.php?43892-Sao-kh%C3%B4ng-thi%E1%BA%BFu-End-If

quanvantruong · 10/3/13

Em mới học lập trình VBA, còn rất nhiều chỗ không biết mong mọi người chỉ bảo

Dưới đây có 1 đoạn code, em không hiểu lắm, mong mọi người viết chú thích dùm em.
Ở đoạn khai báo: "Dim tmparr, arr(), Tmp, Item, sArr()" thì tmparr, item, sArr là gì, em chả hiểu.

Sub List()
Dim tmparr, arr(), Tmp, Item, sArr()
Dim i As Long, j As Long, iR As Long, n As Byte, st1, st2
[H1:Z1000].ClearContents
tmparr = Range("A1", [A655356].End(3)).Value
ReDim arr(1 To 3, 1 To 2)
arr(1, 1) = Tmp: arr(1, 2) = "VT"
Tmp = CStr(Trim([F3]))
For Each Item In tmparr
iR = iR + 1
If CStr(Trim(Item)) = Tmp Then
n = n + 1
arr(2, 2) = [B:B].Cells(iR + 1).Value
arr(3, 1) = "X": arr(3, 2) = "Z"
For j = iR To UBound(tmparr, 1)
If Trim(tmparr(j, 1)) = "PROFILE" Then st1 = j
If Trim(tmparr(j, 1)) = "LEVEL PARAMS" Then st2 = j: Exit For
Next
sArr = Range("A" & st1 & "", "B" & st2 & "").Value
Range("H1").Resize(3, 2).Offset(, 3 * n - 3) = arr
Range("H4").Resize(UBound(sArr, 1), 2).Offset(, 3 * n - 3) = sArr
End If
Next
End Sub

thanhlong68 · 31/3/13

Nhờ sửa giùm em code này

Em muốn sau khi in sẽ lưu lại được các thông tin tại sheet "SAVE" nhờ mọi người sửa giúp
(bài này em sưu tập lại của bác "dhn46" trên diễn đàn)
Em cám ơn

Hoàng Trọng Nghĩa · 31/3/13

thanhlong68 đã viết:
Em muốn sau khi in sẽ lưu lại được các thông tin tại sheet "SAVE" nhờ mọi người sửa giúp
(bài này em sưu tập lại của bác "dhn46" trên diễn đàn)
Em cám ơn

Nhìn code của bạn tôi thấy khó "mò" quá, tôi thay cho bạn những thủ tục mới luôn đây!

Dưới đây là thủ tục In Tùy Chọn:

[GPECODE=vb]Sub InTuyChon2()
Dim RangeSelect As Range
On Error GoTo ExitSub
Set RangeSelect = Application.InputBox( _
"Quet chon vung can in " & String(2, vbLf) & _
"Cot B Sheet 'Data'", _
"Chon Code nhan vien de in", Type:=8)

Dim EndRow As Long, h As Long, n As Long, StartRow As Long
Dim RangeItem As Range, sArray As Variant, SelArr() As Variant

StartRow = 5
EndRow = Sheets("Data").Range("A65536").End(xlUp).Row + 1

For Each RangeItem In RangeSelect
h = RangeItem.Row
If h > StartRow And h < EndRow Then
n = n + 1
ReDim Preserve SelArr(1 To n)
SelArr(n) = h - StartRow
End If
Next

If n Then
Call SpeedOn
Call ResizeForm1
Dim RowFormat As Long, i As Long, j As Long
RowFormat = (n \ 3) + 1

For i = 1 To RowFormat
j = i * 8 - 7
Call ReSizeForm2(j)
Next

sArray = Sheets("Data").Range("A6

" & EndRow - 1).Value

Sheets("KQ").Select

Dim CrtArr As Variant, iMod As Byte, iLoop As Long, r As Long, c As Byte
iLoop = 2
ReDim CrtArr(1 To n, 1 To 4)
For r = 1 To n
For c = 1 To 4
CrtArr(r, c) = sArray(SelArr(r), c)
Next
Range("IDCard")(3, 2) = CrtArr(r, 3)
Range("IDCard")(4, 2) = CrtArr(r, 2)
Range("IDCard")(7, 2) = CrtArr(r, 4)
Range("IDCard").Copy
iMod = r Mod 3

With Sheets("KQ")
Select Case iMod
Case 0
.Cells(iLoop, 12).Select
iLoop = iLoop + 8
Case 1
.Cells(iLoop, 2).Select
Case 2
.Cells(iLoop, 7).Select
End Select
.Paste
End With
Next
Sheets("Save").Range("A65536").End(xlUp).Offset(1).Resize(n, 4) = CrtArr
End If
ExitSub:
Call SpeedOff
End Sub
[/GPECODE]

Có 1 số thủ tục như: Call ResizeForm1 & Call ReSizeForm2 là nhằm định dạng lại hàng, cột ở sheet Form và sheet KQ.

Tương tự như In STT (xem trong file).

thanhlong68 · 31/3/13

Bạn làm rất đúng ý mình nhưng mình không tìm thấy sheet form đâu nữa để thiết kế lại mẫu in bạn ạ. Phiền bạn trả lời giúp mình với

Hoàng Trọng Nghĩa · 31/3/13

thanhlong68 đã viết:
Bạn làm rất đúng ý mình nhưng mình không tìm thấy sheet form đâu nữa để thiết kế lại mẫu in bạn ạ. Phiền bạn trả lời giúp mình với

Bạn bấm Alt+F11 để có cửa sổ VBE, bạn chọn vào tên sheet Form sau đó chọn trong thuộc tính của nó là Visible, chọn -1 (nếu giấu lại thì chọn 2), mục đích là tránh người khác hoặc mình vô tình thay đổi cấu trúc của form đó. Lưu ý, tôi đặt cái thẻ trên form đó là "IDCard" bạn nhé, nếu thay đổi gì thì nhớ chỉnh sửa trong code luôn nhé!

Lưu ý ở các thủ tục này:

Mã:

            Range("IDCard")(3, 2) = CrtArr(r, 3)
            Range("IDCard")(4, 2) = CrtArr(r, 2)
            Range("IDCard")(7, 2) = CrtArr(r, 4)
            Range("IDCard").Copy
            iMod = r Mod 3

Hoàng Trọng Nghĩa · 31/3/13

À, sửa lại thủ tục ResizeForm1 này nhé, thay vì:

PHP:

        With Sheets("KQ")
            .Columns("A:E").PasteSpecial Paste:=xlPasteFormats
            .Columns("F:J").PasteSpecial Paste:=xlPasteFormats
            .Columns("K:O").PasteSpecial Paste:=xlPasteFormats
            .Columns("P:P").PasteSpecial Paste:=xlPasteFormats
            .Cells.Clear
            .DrawingObjects.Delete
        End With

Thì sửa lại như thế này thôi:

PHP:

        With Sheets("KQ")
            .Columns("A:P").PasteSpecial Paste:=xlPasteFormats
            .Cells.Clear
            .DrawingObjects.Delete
        End With

Toàn bộ thủ tục sẽ như vầy:

Mã:

Sub [B]ResizeForm1[/B]()
    With Sheets("Form")
        .Range("G1").ColumnWidth = 0.5
        .Range("H1").ColumnWidth = 6.29
        .Range("I1").ColumnWidth = 11.71
        .Range("J1").ColumnWidth = 12.57
        .Range("K1").ColumnWidth = 11.71
        
        .Range("A11").RowHeight = 5
        .Range("A12").RowHeight = 18
        .Range("A13").RowHeight = 25.5
        .Range("A14").RowHeight = 18
        .Range("A15").RowHeight = 21.75
        .Range("A16").RowHeight = 18
        .Range("A17").RowHeight = 12
        .Range("A18").RowHeight = 19.5
        
        .Columns("G:K").Clear
        .Columns("G:K").Copy
[COLOR=#0000ff]        With Sheets("KQ")
            .Columns("A:P").PasteSpecial Paste:=xlPasteFormats
            .Cells.Clear
            .DrawingObjects.Delete
        End With
[/COLOR]    End With
End Sub

thanhlong68 · 31/3/13

Mình tìm không ra được bạn ạ, (tại mình không được học về VBA) Mong bạn thông cảm giúp mình
Mình còn 1 bài nữa muốn bạn giúp giùm bạn có thể cho mình xin yahoo để hỏi bạn chút được không?
Cám ơn bạn trước

Hoàng Trọng Nghĩa · 31/3/13

thanhlong68 đã viết:
Mình tìm không ra được bạn ạ, (tại mình không được học về VBA) Mong bạn thông cảm giúp mình
Mình còn 1 bài nữa muốn bạn giúp giùm bạn có thể cho mình xin yahoo để hỏi bạn chút được không?
Cám ơn bạn trước

Ui trời ơi, bạn không biết gì về VBA mà "vọc" nhằm file này thì làm gì được hả bạn?

Tôi gửi lại file cho bạn nè! Và nếu muốn hỏi nữa thì gửi câu hỏi lên đây, đừng "meo mẹc" gì hết!

=> Tôi nghĩ ngoài vấn đề này thì chỉ có nước hỏi tiếp là "Bạn ơi, hướng dẫn cho tôi Add hình cho mỗi nhân viên". Hic hic.

thanhlong68 · 31/3/13

Vậy mình nói luôn bạn giúp mình. Mình tính tạo file rồi gửi lên nhưng sợ sẽ bị muộn
Mình có 3 file excel tương ứng với 3 tổ trong mỗi file chứa danh sách 2 nhóm công nhân
Và một file tổng hợp tất cả các danh sách công nhân
Giờ mình muốn tạo list box khi gõ vào. VD nhóm 1 trong file tổng hợp thì sẽ được lọc ra các danh sách có trong nhóm 1 và những nhân viên nào không thuộc trong nhóm 1 sẽ ẩn đi
Mình có gửi mẫu 1 file, các file còn lại tương tự cho tổ 2 và tổ 3 sẽ có các nhóm 3,4 và 5,6 trong 2 file sau
Cám ơn bạn nhiều

Hoàng Trọng Nghĩa · 31/3/13

thanhlong68 đã viết:
Vậy mình nói luôn bạn giúp mình. Mình tính tạo file rồi gửi lên nhưng sợ sẽ bị muộn
Mình có 3 file excel tương ứng với 3 tổ trong mỗi file chứa danh sách 2 nhóm công nhân
Và một file tổng hợp tất cả các danh sách công nhân
Giờ mình muốn tạo list box khi gõ vào. VD nhóm 1 trong file tổng hợp thì sẽ được lọc ra các danh sách có trong nhóm 1 và những nhân viên nào không thuộc trong nhóm 1 sẽ ẩn đi
Mình có gửi mẫu 1 file, các file còn lại tương tự cho tổ 2 và tổ 3 sẽ có các nhóm 3,4 và 5,6 trong 2 file sau
Cám ơn bạn nhiều

Trong 1 file theo tôi thì TỐI KỴ dùng nhiều Mã Font nha bạn. Nên xài 1 thứ thôi!

Có nhiều cách để làm, tuy nhiên, cách làm của tôi như sau:

Cứ mỗi ô có Merge Cells tại cột A bạn đặt Name cho chúng lần lượt là 'Nhom1' và 'Nhom2', sau đó thực hiện thủ tục sau:

PHP:

Private Sub UserForm_Initialize()
    ComboBox1.List = Array("NHÓM 1", "NHÓM 2")
End Sub

Private Sub ComboBox1_Change()
    If ComboBox1.MatchFound Then
        Dim Idx As Long
        Idx = ComboBox1.ListIndex + 1
        Dim sRow As Long, eRow As Long
        With Range("Nhom" & Idx)
            sRow = .Offset(, 1).Row
            eRow = .Offset(1).Row - 1
        End With
        ListBox1.List = Sheets("Sheet1").Range("B" & sRow & ":B" & eRow).Resize(, 3).Value
    Else
        ListBox1.Clear
    End If
End Sub

Như vậy thì bạn cứ việc chọn trong combobox chúng sẽ được hiển thị theo nhóm trong listbox.

thanhlong68 · 31/3/13

Mình muốn nó có dạng như sau bạn có thể giúp mình
Và hơn nữa ý mình muốn là nó có thể lọc từ 3 file khác nhau
VD Bấm "Tổ 1" trên file danh sách tổng hợp thì sẽ được lọc ra các nhân viên có trong tổ 1 thôi

Những câu hỏi về code, xin giải thích các code, đề nghị các bạn gửi vào đây (1 người xem)

Người dùng đang xem chủ đề này

Love Wingchun

Busy

File đính kèm

Nguyễn Khắc Duy

Thành viên tích cực

Thành viên mới

Hướng tới tương lai

Busy

File đính kèm

Huyền thoại GPE

Thành viên chính thức

Thành viên mới

0901452không62

Thành viên gạo cội

Thành viên mới

Thành viên tích cực

Thành viên mới

File đính kèm

Nguyễn Khắc Duy

Thành viên mới

Huyền thoại GPE

Thành viên thường trực

Huyền thoại GPE

Thành viên hoạt động

Thành viên tiêu biểu

File đính kèm

Thành viên tiêu biểu

Hướng tới tương lai

Busy

Thành viên gạo cội

Thành viên mới

File đính kèm

Thành viên thường trực

Thành viên mới

File đính kèm

Thành viên thường trực

Thành viên gạo cội

Thành viên mới

Thành viên thường trực

Huyền thoại GPE

Thành viên mới

Huyền thoại GPE

Thành viên mới

Thành viên tiêu biểu

Bad Excel Member

Thành viên tiêu biểu

Bad Excel Member

Thành viên tiêu biểu

Bad Excel Member

Thành viên tiêu biểu

Thành viên gắn bó

Bad Excel Member

Thành viên tiêu biểu

Thành viên tiêu biểu

Bad Excel Member

Thành viên tiêu biểu

Bad Excel Member

Thành viên mới

0901452không62

Thành viên tiêu biểu

Thành viên mới

Thành viên mới

/(hông là gì!

Thành viên tiêu biểu

Nguyễn Khắc Duy

Thành viên mới

Thành viên mới

Thành viên mới

Thành viên gạo cội

Chuyên gia GPE

Cạo Rồi Khỏi Gội

Chuyên gia GPE

Chuyên gia GPE

File đính kèm

Thành viên mới

Thành viên gạo cội