Chuyên mục xử lý, gỡ rối code VBA (1 người xem)

ndu96081631 · 24/9/13

Topic Những câu hỏi về code, xin giải thích các code... đã quá dài nên mình đóng nó lại và mở topic khác
Tất cả những bài viết liên quan đến việc nhờ giải thích, xử lý và gỡ rối code VBA, các bạn vui lòng đăng tại đây!
Cảm ơn

Ba Tê · 9/9/14

matkinh đã viết:
mình có tập viết code so sánh dữ liệu cột c và cột G nếu khi nhập dữ liệu vào cột c vượt quá số lương cột G thì thông báo xong rồi xoá tại Cells đó luôn. và nếu nhập dữ liệu vào không phải là số VD như: chữ hay ký tự đặc biệt VV thì cũng xoá luôn...hiện tại phát sinh lỗi khi mình xoá dữ liệu cột C...
Mong các bạn trợ giúp xử lý lỗi và giúp mình hoàn thiện code sau
xin cảm ơn

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)If Not Intersect(Target, [C5:C1000]) Is Nothing Then If Target.Value > Target.Offset(, 4) Then MsgBox "Da qua so luong" Target = "" Target.Select Else If Not IsNumeric(Target) Then Target = "" Target.Select End If Cells(Target.Row, 8) = Format(Now, "hh:mm:ss") End If End IfEnd Sub

Thêm 1 cái IF nữa xem sao, Code này của bạn à nghe, Kết quả có thế nào là của bạn

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C5:C1000]) Is Nothing Then
    If Target.Rows.Count = 1 Then ' Thêm cái này'
        If Target.Value > Target.Offset(, 4) Then
            MsgBox "Da qua so luong"
            Target = ""
            Target.Select
        Else
            If Not IsNumeric(Target) Then
                Target = ""
                Target.Select
            End If
            Cells(Target.Row, 8) = Format(Now, "hh:mm:ss")
        End If
    End If
End If
End Sub

phihndhsp · 9/9/14

matkinh đã viết:
Cảm ơn bạn như vậy Tốt rồi .. nhưng khi mình khi mình nhập chữ m hay a vô thì nó vẫn báo đã quá số lượng .nếu được bạn viết vho mình code khác với .yêu cầu vẫn vậy
Xin cảm ơn Bạn nhiều

cái này là do không rõ ràng về kiểu dữ liệu nên nó báo lỗi là đúng, nếu mình nhập vào là số thì nó sẽ so sánh với số, còn nếu mình nhập 1 bên chuỗi 1 bên số thì nó sẽ tự động lấy cái chuỗi so sánh với số theo bảng mã lúc đó thì không còn đúng với yêu cầu của mình nữa. VBA nó rất thoải mái về các kiểu dữ liệu muốn gán kiểu nào gán muốn xài kiểu nào xài chính vì vậy bình thường mình sẽ thấy nó rất dễ xài và không sai cú pháp. Nhưng cái này rất nguy hiểm với dân lập trình, sai cú pháp thì còn biết đường mà sửa chứ sai phép tính thì chỉ có mò mà thôi

Ba Tê · 9/9/14

matkinh đã viết:
Ý mình phòng khi nhập sai dữ liệu thì nó xoá đi thôi. để mình biết nhập lại vì nhiều khi mình hay nhập ẩu lắm nên mới nghĩ ra vậy mong các bạn trợ giúp
xin cảm ơn

Thử lại với cái này xem:

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [C5:C1000]) Is Nothing Then
    If Target.Rows.Count = 1 Then ' Thêm cái này'
        Cells(Target.Row, 8) = Format(Now, "hh:mm:ss")
        If IsNumeric(Target) Then
            If Target.Value > Target.Offset(, 4) Then
                MsgBox "Da qua so luong"
                Target = ""
                Cells(Target.Row, 8) = Empty
                Target.Select
            End If
        Else
            MsgBox "Khong phai Number"
            Target = ""
            Cells(Target.Row, 8) = Empty
            Target.Select
        End If
    End If
End If
End Sub

VetMini · 10/9/14

matkinh đã viết:
Ý mình phòng khi nhập sai dữ liệu thì nó xoá đi thôi. để mình biết nhập lại vì nhiều khi mình hay nhập ẩu lắm nên mới nghĩ ra vậy mong các bạn trợ giúp
xin cảm ơn

Code gì mà non tay quá. Nhập xong rồi xoá thì người nhập làm sao biết tại sao dữ liệu ấy không được chấp nhận?

MsgBox Target.Value & ": không phải là con số"
MsgBox Target.Value & ": vượt cao hơn giới hạn " & Target.Offset(,4).Value

Kiều Mạnh · 10/9/14

VetMini đã viết:
Code gì mà non tay quá. Nhập xong rồi xoá thì người nhập làm sao biết tại sao dữ liệu ấy không được chấp nhận?

MsgBox Target.Value & ": không phải là con số"
MsgBox Target.Value & ": vượt cao hơn giới hạn " & Target.Offset(,4).Value

Học thêm bạn một kiểu Msgbox Hay

boydaigai · 10/9/14

Ở đề tài này e hỏi đã bị khoá : http://www.giaiphapexcel.com/forum/...iêu-đề-thế-nào-cho-bật-được-nội-dung-cần-hỏi)

E loay hoay mãi mà vẫn ko sử dụng được không biết cách sử dụng find method của e sai ở đâu - - - - - -
Kính mong đc khai sáng cái đầu - - - - - - - - -

Pon1 · 10/9/14

nghiaphuc đã viết:
Trong file của bạn, tên sheet "Vibration Test" bị dư 1 dấu cách ở cuối, còn tên sheet "Aux.Speed Adj.Unit" thì dư 1 dấu cách ở đầu. Bạn xóa mấy cái dấu cách này đi là được, hoặc sửa trong code thành "Vibration Test " và " Aux.Speed Adj.Unit"

cám ơn anh, em đã làm được rùi ạ. vậy mà em tìm mãi không ra ... hihi::

boydaigai · 10/9/14

boydaigai đã viết:
Ở đề tài này e hỏi đã bị khoá : http://www.giaiphapexcel.com/forum/...iêu-đề-thế-nào-cho-bật-được-nội-dung-cần-hỏi)

E loay hoay mãi mà vẫn ko sử dụng được không biết cách sử dụng find method của e sai ở đâu - - - - - -
Kính mong đc khai sáng cái đầu - - - - - - - - -

Ai gỡ rối cho e bài này được không, yêu câù e ghi hết ở #310 $-\\/.$ $-\\/.$

Ba Tê · 10/9/14

boydaigai đã viết:
Ai gỡ rối cho e bài này được không, yêu câù e ghi hết ở #310 $-\\/.$ $-\\/.$

Không dùng Find gì đó được không?

PHP:

Private Sub CommandButton1_Click()
Dim Arr(), I As Long
Arr = Range([F9], [F65536].End(xlUp)).Value2
For I = UBound(Arr, 1) To 1 Step -1
    If UCase(Left(Arr(I, 1), 1)) = "X" Then
        [D5] = "X" & Format(Right(Arr(I, 1), 4) + 1, "0000")
        Exit For
    End If
Next I
End Sub

boydaigai · 10/9/14

Ba Tê đã viết:
Không dùng Find gì đó được không?

PHP:

Private Sub CommandButton1_Click() Dim Arr(), I As Long Arr = Range([F9], [F65536].End(xlUp)).Value2 For I = UBound(Arr, 1) To 1 Step -1 If UCase(Left(Arr(I, 1), 1)) =

huuthang_bd · 10/9/14

boydaigai đã viết:
E cảm ơn, biết thêm 1 cách
Nhưng e vẫn hơi thắc mắc cách dùng find, tìm ngược từ dưới lên xlprevious áp dụng vào bài này sao cứ báo error hoài

Biến Rng là biến đối tượng nên khi gán bạn phải dùng từ khóa Set

PHP:

Set rng = ...

Ngoài ra còn một số vấn đề khác:
1. Khi dùng Find, bạn phải bẫy lỗi trong trường hợp không tìm thấy (không có dữ liệu thỏa điều kiện)
2. 'Tìm range hàng cuối cùng có chữ "X" đầu tiên' thì chuỗi tìm kiếm của bạn phải là "X*" chứ không phải là "*X*"
3. Cách 'Cộng thêm 1' của bạn và anh Ba Tê sẽ có kết quả khác nhau nếu dữ liệu tìm được là X9999.
- Của bạn kết quả là: X0000
- Của anh Ba Tê kết quả là: X10000
Vì vậy, tùy vào kết quả mà bạn muốn mà chọn cách phù hợp.

boydaigai · 10/9/14

huuthang_bd đã viết:
Biến Rng là biến đối tượng nên khi gán bạn phải dùng từ khóa Set

PHP:

Set rng = ...

Ngoài ra còn một số vấn đề khác:
1. Khi dùng Find, bạn phải bẫy lỗi trong trường hợp không tìm thấy (không có dữ liệu thỏa điều kiện)
2. 'Tìm range hàng cuối cùng có chữ

boydaigai · 10/9/14

E hỏi thêm giả sử không tìm thấy dữ liệu thỏa mãn điều kiện có chữ cái đầu là X thì cho kết quả trả về X0000. Thì sẽ đc xử lý thế nào ạ -0-/.

lhthai · 11/9/14

Chào Các Anh GPE
Mình tìm trên trang diễn dàn có code sau nay muốn sửa kết quả copy trả về Value được không

Mã:

[TABLE="width: 623"]
[TR]
[TD]Private Sub Copysheet_Click()[/TD]
[/TR]
[TR]
[TD]With Application.FileDialog(1)[/TD]
[/TR]
[TR]
[TD]        .InitialFileName = ThisWorkbook.Path[/TD]
[/TR]
[TR]
[TD]        .Title = "Chon file nguon"[/TD]
[/TR]
[TR]
[TD]        .FilterIndex = 3[/TD]
[/TR]
[TR]
[TD]        .AllowMultiSelect = False[/TD]
[/TR]
[TR]
[TD]        Do[/TD]
[/TR]
[TR]
[TD]            .Show[/TD]
[/TR]
[TR]
[TD]            If .SelectedItems.Count = 0 Then Exit Sub[/TD]
[/TR]
[TR]
[TD]            If .SelectedItems(1) = ThisWorkbook.FullName Then MsgBox "Khong chon file nay!"[/TD]
[/TR]
[TR]
[TD]        Loop Until .SelectedItems(1) <> ThisWorkbook.FullName[/TD]
[/TR]
[TR]
[TD]        With Workbooks.Open(.SelectedItems(1))[/TD]
[/TR]
[TR]
[TD][COLOR=#ff0000]            .Sheets(1).Range("A1:F20").Copy ThisWorkbook.Sheets(1).[A1][/COLOR][/TD]
[/TR]
[TR]
[TD][COLOR=#ff0000]            .Sheets(1).Range("A28:M200").Copy ThisWorkbook.Sheets(1).[A28][/COLOR][/TD]
[/TR]
[TR]
[TD]            .Close False[/TD]
[/TR]
[TR]
[TD]        End With[/TD]
[/TR]
[TR]
[TD]    End With[/TD]
[/TR]
[TR]
[TD]End Sub

[/TD]
[/TR]
[/TABLE]

Let'GâuGâu · 11/9/14

lhthai đã viết:

Chào Các Anh GPE
Mình tìm trên trang diễn dàn có code sau nay muốn sửa kết quả copy trả về Value được không

Mã:

[TABLE="width: 623"]
[TR]
[TD]Private Sub Copysheet_Click()[/TD]
[/TR]
[TR]
[TD]With Application.FileDialog(1)[/TD]
[/TR]
[TR]
[TD]        .InitialFileName = ThisWorkbook.Path[/TD]
[/TR]
[TR]
[TD]        .Title = "Chon file nguon"[/TD]
[/TR]
[TR]
[TD]        .FilterIndex = 3[/TD]
[/TR]
[TR]
[TD]        .AllowMultiSelect = False[/TD]
[/TR]
[TR]
[TD]        Do[/TD]
[/TR]
[TR]
[TD]            .Show[/TD]
[/TR]
[TR]
[TD]            If .SelectedItems.Count = 0 Then Exit Sub[/TD]
[/TR]
[TR]
[TD]            If .SelectedItems(1) = ThisWorkbook.FullName Then MsgBox "Khong chon file nay!"[/TD]
[/TR]
[TR]
[TD]        Loop Until .SelectedItems(1) <> ThisWorkbook.FullName[/TD]
[/TR]
[TR]
[TD]        With Workbooks.Open(.SelectedItems(1))[/TD]
[/TR]
[TR]
[TD][COLOR=#ff0000]            .Sheets(1).Range("A1:F20").Copy ThisWorkbook.Sheets(1).[A1][/COLOR]
[/TD]
[/TR]
[TR]
[TD][COLOR=#ff0000]            .Sheets(1).Range("A28:M200").Copy ThisWorkbook.Sheets(1).[A28][/COLOR]
[/TD]
[/TR]
[TR]
[TD]            .Close False[/TD]
[/TR]
[TR]
[TD]        End With[/TD]
[/TR]
[TR]
[TD]    End With[/TD]
[/TR]
[/TABLE]

bạn có thể dùng special paste

Mã:

[COLOR=#ff0000] .Sheets(1).Range("A1:F20").Copy 
ThisWorkbook.Sheets(1).[A1][/COLOR].specialpaste

[COLOR=#ff0000] .Sheets(1).Range("A28:M200").Copy 
ThisWorkbook.Sheets(1).[A28][/COLOR].specialpaste

hoặc bỏ qua luôn bộ nhớ clipboard

Mã:

[COLOR=#ff0000][COLOR=#ff0000]ThisWorkbook.Sheets(1).[A1:F20][/COLOR].value=.Sheets(1).Range("A1:F20").value

[/COLOR]

Hoàng Trọng Nghĩa · 11/9/14

lhthai đã viết:
Chào Các Anh GPE
Mình tìm trên trang diễn dàn có code sau nay muốn sửa kết quả copy trả về Value được không

Mã:

[TABLE="width: 623"] [TR] [TD][/TD] [/TR] [TR] [TD][COLOR=#ff0000] .Sheets(1).Range("A1:F20").Copy ThisWorkbook.Sheets(1).[A1][/COLOR][/TD] [/TR] [TR] [TD][COLOR=#ff0000] .Sheets(1).Range("A28:M200").Copy ThisWorkbook.Sheets(1).[A28][/COLOR][/TD] [/TR] [TR] [TD]

[/TD]
[/TR]
[/TABLE]

Thay màu đỏ thành:

Mã:

            .Sheets(1).Range("A1:F20").Copy
            ThisWorkbook.Sheets(1).[A1].PasteSpecial 3
            .Sheets(1).Range("A28:M200").Copy
            ThisWorkbook.Sheets(1).[A28].PasteSpecial 3

Hoàng Trọng Nghĩa · 11/9/14

Let'GâuGâu đã viết:
bạn có thể dùng special paste

Mã:

[COLOR=#ff0000] .Sheets(1).Range("A1:F20").Copy ThisWorkbook.Sheets(1).[A1][/COLOR].specialpaste [COLOR=#ff0000] .Sheets(1).Range("A28:M200").Copy ThisWorkbook.Sheets(1).[A28][/COLOR].specialpaste

Nếu đã dùng PasteSpecial thì hoặc là:

Mã:

.PasteSpecial [COLOR=#0000cd]Paste:=xlPasteValues[/COLOR]

Hoặc:

Mã:

.PasteSpecial [COLOR=#0000CD]3[/COLOR]

Chứ nếu không dùng thông số (xanh), thì chúng cũng như Paste bình thường thôi, không hơn không kém.

Vả lại "specialpaste" hình như viết cũng không đúng nữa nhỉ!

lhthai · 11/9/14

Hoàng Trọng Nghĩa đã viết:
[/TD]
[/TR]
[/TABLE]

Thay màu đỏ thành:

Mã:

.Sheets(1).Range("A1:F20").Copy ThisWorkbook.Sheets(1).[A1].PasteSpecial 3 .Sheets(1).Range("A28:M200").Copy ThisWorkbook.Sheets(1).[A28].PasteSpecial 3

Chào Anh
Em copy vào chạy không được em gửi file anh xem nha
File book2 lấy giữ liệu từ các file khác

Hoàng Trọng Nghĩa · 11/9/14

lhthai đã viết:
Chào Anh
Em copy vào chạy không được em gửi file anh xem nha
File book2 lấy giữ liệu từ các file khác

Cụ thể là lỗi gì? Nhận dữ liệu từ file nào?

-----------------------------------------------

Tôi tạm sửa lại thế này cho bạn:

Mã:

Private Sub CopySheet_Click()
With Application.FileDialog(1)
        .InitialFileName = ThisWorkbook.Path
        .Title = "Chon file nguon"
        .FilterIndex = 3
        .AllowMultiSelect = False
        Do
            .Show
            If .SelectedItems.Count = 0 Then Exit Sub
            If .SelectedItems(1) = ThisWorkbook.FullName Then MsgBox "Khong chon file nay!"
        Loop Until .SelectedItems(1) <> ThisWorkbook.FullName
[COLOR=#800080]        Application.DisplayAlerts = False[/COLOR]
[COLOR=#0000ff]        ThisWorkbook.Sheets(1).Cells.ClearContents[/COLOR]
        With Workbooks.Open(.SelectedItems(1))
            .Sheets(1).Range("A1:F20").Copy
[COLOR=#0000ff]            ThisWorkbook.Sheets(1).[A1].PasteSpecial Paste:=xlPasteValues[/COLOR]
            .Sheets(1).Range("A28:M200").Copy
[COLOR=#0000ff]            ThisWorkbook.Sheets(1).[A28].PasteSpecial Paste:=xlPasteValues[/COLOR]
            .Close False
        End With
[COLOR=#800080]        Application.DisplayAlerts = True[/COLOR]
    End With
End Sub

lhthai · 11/9/14

Hoàng Trọng Nghĩa đã viết:

Cụ thể là lỗi gì? Nhận dữ liệu từ file nào?

-----------------------------------------------

Tôi tạm sửa lại thế này cho bạn:

Mã:

Private Sub CopySheet_Click()
With Application.FileDialog(1)
        .InitialFileName = ThisWorkbook.Path
        .Title = "Chon file nguon"
        .FilterIndex = 3
        .AllowMultiSelect = False
        Do
            .Show
            If .SelectedItems.Count = 0 Then Exit Sub
            If .SelectedItems(1) = ThisWorkbook.FullName Then MsgBox "Khong chon file nay!"
        Loop Until .SelectedItems(1) <> ThisWorkbook.FullName
[COLOR=#800080]        Application.DisplayAlerts = False[/COLOR]
[COLOR=#0000ff]        ThisWorkbook.Sheets(1).Cells.ClearContents[/COLOR]
        With Workbooks.Open(.SelectedItems(1))
            .Sheets(1).Range("A1:F20").Copy
[COLOR=#0000ff]            ThisWorkbook.Sheets(1).[A1].PasteSpecial Paste:=xlPasteValues[/COLOR]
            .Sheets(1).Range("A28:M200").Copy
[COLOR=#0000ff]            ThisWorkbook.Sheets(1).[A28].PasteSpecial Paste:=xlPasteValues[/COLOR]
            .Close False
        End With
[COLOR=#800080]        Application.DisplayAlerts = True[/COLOR]
    End With
End Sub

_Rất hay cám ơn anh nha
Em muốn bổ sung thếm 1 điều kiện như sau
Chẳng hạn trong các file em gửi co trường họp sau tên file NVY300 có 18 dòng còn file NVY914 có 21dong
Em muốn khi copy chỉ lấy giá trị của cột A:F & A:M dán qua thôi không biết code có làm được không anh
Em chỉ hỏi thêm vậy thôi

lhthai · 12/9/14

Chào các anh GPE
Hiện tại em có file chạy macro sau có điều kiện như sau
Tại Sheet Data dùng Advancel Filter để lộc kết quả
Nay muốn kết quả trả sang sheet 3 được không

Mã:

Sub Datasort()
    Range("B1:M6500").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        Sheets("SORT").Range("B2:M100"), CopyToRange:=Range("T2:AE2"), Unique:= _
        False
    Range("B1:M6500").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        Sheets("SORT").Range("S2:AD100"), CopyToRange:=Range("AJ2:AU2"), Unique:= _
        False
    ActiveWindow.SmallScroll ToRight:=4
    Range("T2:AF2").Select
    Range("AF2").Activate
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Sort Key1:=Range("AF3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    ActiveWindow.LargeScroll ToRight:=0
    ActiveWindow.SmallScroll ToRight:=7
    Range("AJ2:AV2").Select
    Range("AV2").Activate
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Sort Key1:=Range("AV3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("B2").Select
End Sub

ninhmoon · 12/9/14

Tìm lỗi code

[GPECODE=vb]
Sub hide1colum()
Dim n As String, t As String, numcol As Long
n = ActiveSheet.Shapes(Application.Caller).Name
t = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
numcol = Mid(t, 2, Application.WorksheetFunction.Find(")", t) - 2)

If ActiveSheet.Shapes(n).ControlFormat.Value = xlOn Then
Columns(numcol).EntireColumn.Hidden = True

Else
Columns(numcol).EntireColumn.Hidden = False
End If

End Sub

[/GPECODE]
Mọi người cho e hỏi, cái
"n = ActiveSheet.Shapes(Application.Caller).Name" e bị sai cái chi mà ko chạy được

Hoàng Trọng Nghĩa · 12/9/14

Bạn đưa file đó lên đây, đoán non đoán già trong cái shape của bạn ghi chép cái gì thì khó khăn quá!

Hoàng Trọng Nghĩa · 13/9/14

lhthai đã viết:
_Rất hay cám ơn anh nha
Em muốn bổ sung thếm 1 điều kiện như sau
Chẳng hạn trong các file em gửi co trường họp sau tên file NVY300 có 18 dòng còn file NVY914 có 21dong
Em muốn khi copy chỉ lấy giá trị của cột A:F & A:M dán qua thôi không biết code có làm được không anh
Em chỉ hỏi thêm vậy thôi

Tôi chưa hiểu cái dòng tô đỏ. Có phải bạn muốn nói là ở cột A:F - A:M nếu giá trị có bao nhiêu hàng thì lấy bấy nhiêu hàng (dù nhiều hàng hay ít hàng) phải vậy không?

ninhmoon · 13/9/14

Hoàng Trọng Nghĩa đã viết:
Bạn đưa file đó lên đây, đoán non đoán già trong cái shape của bạn ghi chép cái gì thì khó khăn quá!

Em đưa file nên. tại e cũng ko hiểu nó thế nào

Hoàng Trọng Nghĩa · 13/9/14

lhthai đã viết:

Chào các anh GPE
Hiện tại em có file chạy macro sau có điều kiện như sau
Tại Sheet Data dùng Advancel Filter để lộc kết quả
Nay muốn kết quả trả sang sheet 3 được không

Mã:

Sub Datasort()
    Range("B1:M6500").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        Sheets("SORT").Range("B2:M100"), CopyToRange:=Range("T2:AE2"), Unique:= _
        False
    Range("B1:M6500").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        Sheets("SORT").Range("S2:AD100"), CopyToRange:=Range("AJ2:AU2"), Unique:= _
        False
    ActiveWindow.SmallScroll ToRight:=4
    Range("T2:AF2").Select
    Range("AF2").Activate
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Sort Key1:=Range("AF3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    ActiveWindow.LargeScroll ToRight:=0
    ActiveWindow.SmallScroll ToRight:=7
    Range("AJ2:AV2").Select
    Range("AV2").Activate
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Sort Key1:=Range("AV3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("B2").Select
End Sub

Không biết có đúng không, do bạn dùng AdvancedFilter mà lại chọn hết các cột, có nghĩa là bạn copy toàn bộ dữ liệu qua nên tôi làm cho bạn như thế này mà không cần phải dùng đến AdvancedFilter:

Mã:

Sub Datasort()
    Dim Arr
    Dim r As Long
    With Sheets("DATA")
        r = .Range("B" & Rows.Count).End(xlUp).Row
        Arr = .Range("B2:M" & r)
        r = UBound(Arr)
    End With
    With Sheets("Sheet3")
        .Range("B3:M" & Rows.Count).ClearContents
        .Range("R3:AC" & Rows.Count).ClearContents
        .Range("B3:M3").Resize(r) = Arr
        .Range("R3:AC3").Resize(r) = Arr
        .Range("B3:N3").Resize(r).Sort .Range("N2"), xlAscending
        .Range("R3:AD3").Resize(r).Sort .Range("AD2"), xlAscending
    End With
End Sub

Xem file đính kèm.

Hoàng Trọng Nghĩa · 13/9/14

ninhmoon đã viết:
Em đưa file nên. tại e cũng ko hiểu nó thế nào

Trời ơi, cái file của bạn đâu rồi? Sao không up lên đây đi?

tanlocsonyuser · 13/9/14

Mọi người sao mình dung code này thì bị lỗi Out of range vậy?

Mã:

 Set d = CreateObject("excel.Application")
 Worksheets("BANG2").Cells(1, 2).Value = d.WorksheetFunction.max(IIf(Range("A4:$A100").Value = test, Range("F4:F100"), ""))

Hoàng Trọng Nghĩa · 13/9/14

tanlocsonyuser đã viết:
Mọi người sao mình dung code này thì bị lỗi Out of range vậy?

Mã:

Set d = CreateObject("excel.Application") Worksheets("BANG2").Cells(1, 2).Value = d.WorksheetFunction.max(IIf(Range("A4:$A100").Value = test, Range("F4:F100"), ""))

Gửi cả Sub lên đây đi bạn ơi, không phải nó tô vàng ở chỗ này mà lỗi tại đây đâu, lỗi này có lẽ do khai báo, nếu quá kiểu dữ liệu sẽ cho ra lỗi này.

thanhduc_iit · 15/9/14

Mã:

CThuc "NGOAI", "93001", "C8"
CThuc "NOI", "93001", "C8"
CThuc "TONG", "93001", "C8"
CThuc "NGOAI", "93007", "C15"
CThuc "NOI", "93007", "C15"
CThuc "TONG", "93007", "C15"
CThuc "NGOAI", "93002", "C22"
CThuc "NOI", "93002", "C22"
CThuc "TONG", "93002", "C22"
CThuc "NGOAI", "93003", "C29"
CThuc "NOI", "93003", "C29"
CThuc "TONG", "93003", "C29"
CThuc "NGOAI", "93004", "C36"
CThuc "NOI", "93004", "C36"
CThuc "TONG", "93004", "C36"
CThuc "NGOAI", "93016", "C43"
CThuc "NOI", "93016", "C43"
CThuc "TONG", "93016", "C43"
CThuc "NGOAI", "93006", "C50"
CThuc "NOI", "93006", "C50"
CThuc "TONG", "93006", "C50"
CThuc "NGOAI", "93005", "C57"
CThuc "NOI", "93005", "C57"
CThuc "TONG", "93005", "C57"
CThuc "NGOAI", "93101", "C64"
CThuc "NOI", "93101", "C64"
CThuc "TONG", "93101", "C64"
CThuc "NGOAI", "93102", "C71"
CThuc "NOI", "93102", "C71"
CThuc "TONG", "93102", "C71"

Sub CThuc(a As String, b As String, c As String)
    ...
End Sub

Em làm mãi mà vẫn chưa tìm ra cách rút gọn đoạn code trên &&&%$R

Các bác giúp em với ạ

hungpecc1 · 15/9/14

thanhduc_iit đã viết:

Mã:

CThuc "NGOAI", "93001", "C8"
CThuc "NOI", "93001", "C8"
CThuc "TONG", "93001", "C8"
CThuc "NGOAI", "93007", "C15"
CThuc "NOI", "93007", "C15"
CThuc "TONG", "93007", "C15"
CThuc "NGOAI", "93002", "C22"
CThuc "NOI", "93002", "C22"
CThuc "TONG", "93002", "C22"
CThuc "NGOAI", "93003", "C29"
CThuc "NOI", "93003", "C29"
CThuc "TONG", "93003", "C29"
CThuc "NGOAI", "93004", "C36"
CThuc "NOI", "93004", "C36"
CThuc "TONG", "93004", "C36"
CThuc "NGOAI", "93016", "C43"
CThuc "NOI", "93016", "C43"
CThuc "TONG", "93016", "C43"
CThuc "NGOAI", "93006", "C50"
CThuc "NOI", "93006", "C50"
CThuc "TONG", "93006", "C50"
CThuc "NGOAI", "93005", "C57"
CThuc "NOI", "93005", "C57"
CThuc "TONG", "93005", "C57"
CThuc "NGOAI", "93101", "C64"
CThuc "NOI", "93101", "C64"
CThuc "TONG", "93101", "C64"
CThuc "NGOAI", "93102", "C71"
CThuc "NOI", "93102", "C71"
CThuc "TONG", "93102", "C71"

Sub CThuc(a As String, b As String, c As String)
    ...
End Sub

Em làm mãi mà vẫn chưa tìm ra cách rút gọn đoạn code trên &&&%$R

Các bác giúp em với ạ

Rút gọn kiểu này được không /

Mã:

Sub GPE()
    Dim Arr1, Arr2
    Dim i&
        Arr1 = Array("93001,93002,93007,....)
        Arr2 = Array("C8","C12","C15",....)
        For i = 0 To UBound(Arr1)
            CThuc "NOI", Arr1(i), Arr2(i)
            CThuc "NGOAI", Arr1(i), Arr2(i)
            CThuc "TONG", Arr1(i), Arr2(i)
        Next
End Sub

thanhduc_iit · 15/9/14

hungpecc1 đã viết:

Rút gọn kiểu này được không /

Mã:

Sub GPE()
    Dim Arr1, Arr2
    Dim[COLOR=#ff0000] i&[/COLOR]
        Arr1 = Array("93001,93002,93007,....)
        Arr2 = Array("C8","C12","C15",....)
        For i = 0 To UBound(Arr1)
            CThuc "NOI", Arr1(i), Arr2(i)
            CThuc "NGOAI", Arr1(i), Arr2(i)
            CThuc "TONG", Arr1(i), Arr2(i)
        Next
End Sub

Em cũng từng thử cách này, vấn đề nằm ngay chổ i& :-=

Nhưng vẫn bị cái ByRef argument type mismatch
Thanks bác

hungpecc1 · 15/9/14

thanhduc_iit đã viết:
Em cũng từng thử cách này, vấn đề nằm ngay chổ i&
Nhưng vẫn bị cái ByRef argument type mismatch
Thanks bác

test thử code sau ,mình nghĩ vẫn đền không phải nằm ở chỗ biến i

Mã:

Sub GPE()
    Dim Arr1, Arr2
    Dim i&
        Arr1 = Array("93001", "93002", "93007")
        For i = 0 To UBound(Arr1)
            Debug.Print Arr1(i)
        Next
End Sub

muốn biến cụ thể thế nào chỉ cách upfile cụ thể lên mới biết được

phihndhsp · 15/9/14

Xin hỏi Dim i&?? là gì? có phải là khai báo kiểu con trỏ không? xin được giải thích để học hỏi. Xin cảm ơn nhiều

quocphuoc88 · 15/9/14

phihndhsp đã viết:
Xin hỏi Dim i&?? là gì? có phải là khai báo kiểu con trỏ không? xin được giải thích để học hỏi. Xin cảm ơn nhiều

theo mình biết là khai báo biến i , ở đây tác giả ghi tắt bằng ký hiệu, các ký hiệu là :
String $
Integer %
Long &
Single !
Double #
Currency @

Hau151978 · 16/9/14

thanhduc_iit đã viết:
Em cũng từng thử cách này, vấn đề nằm ngay chổ i&
Nhưng vẫn bị cái ByRef argument type mismatch
Thanks bác

Mình nghĩ có thể do sai kiểu tham số. Bạn thử sửa thành
Sub CThuc(a,b,c)
End sub
xem được không, mình không có máy để test.

VetMini · 16/9/14

Hau151978 đã viết:
Mình nghĩ có thể do sai kiểu tham số. Bạn thử sửa thành
Sub CThuc(a,b,c)
End sub
xem được không, mình không có máy để test.

Bạn nghĩ đúng rồi. Đây là lỗi compiler chứ không phải lỗi run time. Vì Arr1 chỉ khai báo suông không có kiểu cho nên mặc định là variant. Khi compiler kết nối với sub CThuc thì không ép kiểu được sang string.
Lưu ý là compiler kết nối trước khi code chạy - sau khi code chạy thì nó biết Arr1(i) là sttring.
Nếu bạn đổi khai báo Dim Arr1() as string thì sẽ không còn lỗi compiler nữa. Nhưng lúc chạy, bạn sẽ bị lỗi "type mismatch" ở dỏng Arr1 = Array(...). Đó là lỗi run time.
Nếu hàm CThuc không thay đổi trị của tham số thì (khai báo ByVal) có thể dùng CThuc "TONG", Cstr(Arr1(i)), Cstr(Arr2(i)).
Lưu ý là code của người hỏi căn bản đã phạm lỗi gọi hàm khi khai báo tham biến (ByRef) nhưng nạp tham số là hằng ("TONG").

Đây là tôi trả lời cho riêng vấn đề ngữ thuật. Tôi vốn không muốn trả lời thẳng cho người hỏi vì 2 lý do: 1. tôi kỵ những người hỏi dùng tiếng Anh; 2. chen ngang câu hỏi không thuộc về thuật toán vào thớt này là bất lịch sự.

=== bổ sung ===
Câu hỏi này vốn được người hỏi chen ngang vào thớt "Trao đổi về thuật toán trong lập trình VBA". Vì vấn đề không phải thuật toán cho nên tôi khẳng định hành động là bất lịch sự.
Sáng nay BQT đã dời nó vào đây, đúng chỗ của nó hơn.

Excel365 · 16/9/14

Rút gon code

[GPECODE=vb]Option ExplicitSub CopyCongSP()
Dim lRs As Long
lRs = LDQuanLy.[A65500].End(xlUp).Row - 10
ActiveSheet.Cells(11, 1).FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
ActiveSheet.Cells(11, 1).AutoFill Cells(11, 1).Resize(lRs)
ActiveSheet.Cells(11, 2).FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
ActiveSheet.Cells(11, 2).AutoFill Cells(11, 2).Resize(lRs)
ActiveSheet.Cells(11, 3).FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
ActiveSheet.Cells(11, 3).AutoFill Cells(11, 3).Resize(lRs)
End Sub[/GPECODE]

Với đoạn code như trên thì cho em hỏi có cách nào để viết cho nó ngắn gon hơn nữa không?
Nhờ các anh chị giúp đỡ.
Trân trọng

nmhung49 · 16/9/14

huuduy.duy đã viết:
[GPECODE=vb]Option ExplicitSub CopyCongSP()
Dim lRs As Long
lRs = LDQuanLy.[A65500].End(xlUp).Row - 10
ActiveSheet.Cells(11, 1).FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
ActiveSheet.Cells(11, 1).AutoFill Cells(11, 1).Resize(lRs)
ActiveSheet.Cells(11, 2).FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
ActiveSheet.Cells(11, 2).AutoFill Cells(11, 2).Resize(lRs)
ActiveSheet.Cells(11, 3).FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
ActiveSheet.Cells(11, 3).AutoFill Cells(11, 3).Resize(lRs)
End Sub[/GPECODE]

Với đoạn code như trên thì cho em hỏi có cách nào để viết cho nó ngắn gon hơn nữa không?
Nhờ các anh chị giúp đỡ.
Trân trọng

Rút gọn thì vậy với With ...End with

[GPECODE=vb]
Sub Rutgon()
With ActiveSheet
With .Cells(11, 1)
.FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
.AutoFill Cells(11, 1).Resize(lRs)
End With
With .Cells(11, 2)
.FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
.AutoFill Cells(11, 2).Resize(lRs)
End With
With .Cells(11, 3)
.FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
.AutoFill Cells(11, 3).Resize(lRs)
End With
End Sub

[/GPECODE]

Excel365 · 16/9/14

nmhung49 đã viết:
Rút gọn thì vậy với With ...End with

[GPECODE=vb]
Sub Rutgon()
With ActiveSheet
With .Cells(11, 1)
.FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
.AutoFill Cells(11, 1).Resize(lRs)
End With
With .Cells(11, 2)
.FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
.AutoFill Cells(11, 2).Resize(lRs)
End With
With .Cells(11, 3)
.FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
.AutoFill Cells(11, 3).Resize(lRs)
End With
End Sub

[/GPECODE]

Code báo lỗi ạ, nhờ nmhung49 xem lại giúp em

Hoàng Trọng Nghĩa · 16/9/14

huuduy.duy đã viết:
[GPECODE=vb]Option ExplicitSub CopyCongSP()
Dim lRs As Long
lRs = LDQuanLy.[A65500].End(xlUp).Row - 10
ActiveSheet.Cells(11, 1).FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
ActiveSheet.Cells(11, 1).AutoFill Cells(11, 1).Resize(lRs)
ActiveSheet.Cells(11, 2).FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
ActiveSheet.Cells(11, 2).AutoFill Cells(11, 2).Resize(lRs)
ActiveSheet.Cells(11, 3).FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
ActiveSheet.Cells(11, 3).AutoFill Cells(11, 3).Resize(lRs)
End Sub[/GPECODE]

Với đoạn code như trên thì cho em hỏi có cách nào để viết cho nó ngắn gon hơn nữa không?
Nhờ các anh chị giúp đỡ.
Trân trọng

Thử xem có đúng ý bạn không nhé!

Mã:

Sub CopyCongSP()
    Dim lRs As Long
[COLOR=#ff0000]    lRs = LDQuanLy.Range("A" & Rows.Count).End(xlUp).Row[/COLOR]
    With ActiveSheet
        .Cells(11, 1).FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
        .Cells(11, 2).FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
        .Cells(11, 3).FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
[COLOR=#ff0000]        Range(.Cells(11, 1), .Cells(11, 3)).AutoFill Range(.Cells(11, 1), .Cells(lRs, 3))[/COLOR]
    End With
End Sub

Excel365 · 16/9/14

Hoàng Trọng Nghĩa đã viết:

Thử xem có đúng ý bạn không nhé!

Mã:

Sub CopyCongSP()
    Dim lRs As Long
[COLOR=#ff0000]    lRs = LDQuanLy.Range("A" & Rows.Count).End(xlUp).Row[/COLOR]
    With ActiveSheet
        .Cells(11, 1).FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
        .Cells(11, 2).FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
        .Cells(11, 3).FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
[COLOR=#ff0000]        Range(.Cells(11, 1), .Cells(11, 3)).AutoFill Range(.Cells(11, 1), .Cells(lRs, 3))[/COLOR]
    End With
End Sub

Dạ đúng ý rồi anh. Cám ơn anh nhiều

Hoàng Trọng Nghĩa · 16/9/14

huuduy.duy đã viết:
Dạ đúng ý rồi anh. Cám ơn anh nhiều

Mà nếu dùng cho ActiveSheet thì cần gì With nữa ta! Ngoại trừ đừng dùng code này khi sheet LDQuanLy đang hiện hành!

Mã:

Sub CopyCongSP()
    Dim lRs As Long
[COLOR=#ff0000]    lRs = LDQuanLy.Range("A" & Rows.Count).End(xlUp).Row[/COLOR]
    Cells(11, 1).FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
    Cells(11, 2).FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
    Cells(11, 3).FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
[COLOR=#ff0000]    Range(Cells(11, 1), Cells(11, 3)).AutoFill Range(Cells(11, 1), Cells(lRs, 3))[/COLOR]
End Sub

Excel365 · 16/9/14

Hoàng Trọng Nghĩa đã viết:
Mà nếu dùng cho ActiveSheet thì cần gì With nữa ta! Ngoại trừ đừng dùng code này khi sheet LDQuanLy đang hiện hành!

Mã:

Sub CopyCongSP() Dim lRs As Long [COLOR=#ff0000] lRs = LDQuanLy.Range("A" & Rows.Count).End(xlUp).Row[/COLOR] Cells(11, 1).FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")" Cells(11, 2).FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")" Cells(11, 3).FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")" [COLOR=#ff0000] Range(Cells(11, 1), Cells(11, 3)).AutoFill Range(Cells(11, 1), Cells(lRs, 3))[/COLOR] End Sub

Nếu muốn cho công thức thành giá trị Value thì sao hả anh

Ba Tê · 16/9/14

huuduy.duy đã viết:
Nếu muốn cho công thức thành giá trị Value thì sao hả anh

Thêm đoạn này phía trên End Sub xem sao

PHP:

Cells.Copy
    Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("A1").Select

Excel365 · 16/9/14

Ba Tê đã viết:
Thêm đoạn này phía trên End Sub xem sao

PHP:

Cells.Copy Range("A1").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Range("A1").Select

Ý cuả em chỉ muốn chuyển giá trị của 3 cột đó sang value, chứ không chuyển toàn bộ sheet ạ

Hoàng Trọng Nghĩa · 16/9/14

huuduy.duy đã viết:
Ý cuả em chỉ muốn chuyển giá trị của 3 cột đó sang value, chứ không chuyển toàn bộ sheet ạ

Thử xem có được không! Không có file nên toàn đoán non đoán già không đó!

Mã:

Sub CopyCongSP()
    Cells(11, 1).FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
    Cells(11, 2).FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
    Cells(11, 3).FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
[COLOR=#0000ff]    Dim lRs As Long, Rng As Range[/COLOR]
[COLOR=#0000ff]    lRs = LDQuanLy.Range("A" & Rows.Count).End(xlUp).Row[/COLOR]
[COLOR=#0000ff]    Set Rng = Range(Cells(11, 1), Cells(lRs, 3))[/COLOR]
[COLOR=#0000ff]    Range(Cells(11, 1), Cells(11, 3)).AutoFill Rng[/COLOR]
[COLOR=#0000ff]    Rng.Value = Rng.Value[/COLOR]
End Sub

phihndhsp · 17/9/14

Hoàng Trọng Nghĩa đã viết:

Mã:

Sub CopyCongSP()
    Cells(11, 1).FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
    Cells(11, 2).FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
    Cells(11, 3).FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
[COLOR=#0000ff]    Dim lRs As Long, Rng As Range[/COLOR]
[COLOR=#0000ff]    lRs = LDQuanLy.Range("A" & Rows.Count).End(xlUp).Row[/COLOR]
[COLOR=#0000ff]    Set Rng = Range(Cells(11, 1), Cells(lRs, 3))[/COLOR]
[COLOR=#0000ff]    Range(Cells(11, 1), Cells(11, 3)).AutoFill Rng[/COLOR]
[COLOR=#0000ff] [/COLOR][B][COLOR=#ff0000]Calculate  [/COLOR][/B][COLOR=#0000ff] 
Rng.Value = Rng.Value[/COLOR]
End Sub

thêm cái đỏ đỏ phòng trường hợp máy tính không tự động chạy công thức, cái này tôi gặp hoài hà

Excel365 · 17/9/14

Sub CopyCongSP()
Cells(11, 1).FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
Cells(11, 2).FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
Cells(11, 3).FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
Dim lRs As Long, Rng As Range
lRs = LDQuanLy.Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Range(Cells(11, 1), Cells(lRs, 3))
Range(Cells(11, 1), Cells(11, 3)).AutoFill Rng
Calculate
Rng.Value = Rng.Value
Cells(11, 3). Format("000000000000")
End Sub
Em thêm vo chỗ màu đổ thì nó báo lỗi 400. Nhờ các anh chị xem giúp em

Hoàng Trọng Nghĩa · 17/9/14

huuduy.duy đã viết:
Sub CopyCongSP()
Cells(11, 1).FormulaR1C1 = "=IF(RC9<>"""",RC[93],"""")"
Cells(11, 2).FormulaR1C1 = "=IF(RC9<>"""",RC[32],"""")"
Cells(11, 3).FormulaR1C1 = "=IF(AND(RC9<>"""",RC[63]<>""""),RC[63],"""")"
Dim lRs As Long, Rng As Range
lRs = LDQuanLy.Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Range(Cells(11, 1), Cells(lRs, 3))
Range(Cells(11, 1), Cells(11, 3)).AutoFill Rng
Calculate
Rng.Value = Rng.Value
Cells(11, 3). Format("000000000000")
End Sub
Em thêm vo chỗ màu đổ thì nó báo lỗi 400. Nhờ các anh chị xem giúp em

Cells(11, 3).NumberFormat = "000000000000"

lhthai · 17/9/14

Chào Các anh
Em muốn copy thêm cột 23,24,25,29 nằm tiếp theo

Mã:

Private Sub CommandButton1_Click()
Dim sArr(), dArr(), i As Long, j As Byte, n As Byte
With Sheet2
   sArr = .Range("G10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
      For j = 1 To 4
         n = Choose(j, 1, 2, 3, 7)
         dArr(i, j) = sArr(i, n)
      Next
   Next
   Sheet1.[B65536].End(3)(2).Resize(i - 1, 4) = dArr
End With
End Sub

VetMini · 18/9/14

lhthai đã viết:
Chào Các anh
Em muốn copy thêm cột 23,24,25,29 nằm tiếp theo
...

Thì chép lại đoạn code kể từ sArr = .Range... cho đến Sheet1.[B...
Sau đó sửa G10 thành AC10, và Sheet1.[B65536].End(3)(2).Resize(i - 1, 4) thành Sheet1.[B65536].End(3)(2).Offset(1, 0).Resize(i - 1, 4)

lhthai · 18/9/14

VetMini đã viết:
Thì chép lại đoạn code kể từ sArr = .Range... cho đến Sheet1.[B...
Sau đó sửa G10 thành AC10, và Sheet1.[B65536].End(3)(2).Resize(i - 1, 4) thành Sheet1.[B65536].End(3)(2).Offset(1, 0).Resize(i - 1, 4)

Copy code tiếp chạy thì báo lỗi tài dòng màu đỏ

Mã:

Private Sub CommandButton1_Click()
Dim sArr(), dArr(), i As Long, j As Byte, n As Byte
With Sheet2
   sArr = .Range("G10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
      For j = 1 To 4
         n = Choose(j, 1, 2, 3, 7)
         dArr(i, j) = sArr(i, n)
      Next
   Next
   Sheet1.[B65536].End(3)(2).Resize(i - 1, 4) = dArr
End With
With Sheet2
   sArr = .Range("AC10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
      For j = 1 To 4
         n = Choose(j, 23, 24, 25, 29)
[COLOR=#ff0000]         dArr(i, j) = sArr(i, n)[/COLOR]
      Next
   Next
   Sheet1.[B65536].End(3)(2).Offset(1, 0).Resize(i - 1, 4) = dArr
End With
End Sub

VetMini · 18/9/14

lhthai đã viết:

Copy code tiếp chạy thì báo lỗi tài dòng màu đỏ

Mã:

Private Sub CommandButton1_Click()
Dim sArr(), dArr(), i As Long, j As Byte, n As Byte
With Sheet2
   sArr = .Range("G10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
      For j = 1 To 4
         n = Choose(j, 1, 2, 3, 7)
         dArr(i, j) = sArr(i, n)
      Next
   Next
   Sheet1.[B65536].End(3)(2).Resize(i - 1, 4) = dArr
End With
With Sheet2
   sArr = .Range("AC10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
      For j = 1 To 4
         n = Choose(j, 23, 24, 25, 29)
[COLOR=#ff0000]        dArr(i, j) = sArr(i, n)[/COLOR]
      Next
   Next
   Sheet1.[B65536].End(3)(2).Offset(1, 0).Resize(i - 1, 4) = dArr
End With
End Sub

Xem lại cho kỹ tôi nói:

1. Copy phần bên trong block With, không phải copy cả block With. Nhưng cái này không quan trọng, chỉ tự nhiên 2 blocks with thì nó rườm rà thôi.

2. Tôi không hề bảo sửa phần n = Choose(j, 1, 2, 3, 7). Sửa phần này thì bị subscript out of range là phải rồi.

lhthai · 18/9/14

VetMini đã viết:
Xem lại cho kỹ tôi nói:

1. Copy phần bên trong block With, không phải copy cả block With. Nhưng cái này không quan trọng, chỉ tự nhiên 2 blocks with thì nó rườm rà thôi.

2. Tôi không hề bảo sửa phần n = Choose(j, 1, 2, 3, 7). Sửa phần này thì bị subscript out of range là phải rồi.

Cám ơn bạn nhiều nha
Trường hợp mình muốn bỏ những o trống được không

Mã:

Private Sub CommandButton1_Click()
Dim sArr(), dArr(), i As Long, j As Byte, n As Byte
With Sheet2
   sArr = .Range("G10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
      For j = 1 To 4
         n = Choose(j, 1, 2, 3, 7)
         dArr(i, j) = sArr(i, n)
      Next
   Next
   Sheet1.[B65536].End(3)(2).Resize(i - 1, 4) = dArr
   sArr = .Range("AC10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
      For j = 1 To 4
         n = Choose(j, 1, 2, 3, 7)
         dArr(i, j) = sArr(i, n)
      Next
   Next
   Sheet1.[B65536].End(3)(2).Offset(1, 0).Resize(i - 1, 4) = dArr
End With
End Sub

nmhung49 · 18/9/14

lhthai đã viết:

Cám ơn bạn nhiều nha
Trường hợp mình muốn bỏ những o trống được không

Mã:

Private Sub CommandButton1_Click()
Dim sArr(), dArr(), i As Long, j As Byte, n As Byte
With Sheet2
   sArr = .Range("G10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
      For j = 1 To 4
         n = Choose(j, 1, 2, 3, 7)
         dArr(i, j) = sArr(i, n)
      Next
   Next
   Sheet1.[B65536].End(3)(2).Resize(i - 1, 4) = dArr
   sArr = .Range("AC10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
      For j = 1 To 4
         n = Choose(j, 1, 2, 3, 7)
         dArr(i, j) = sArr(i, n)
      Next
   Next
   Sheet1.[B65536].End(3)(2).Offset(1, 0).Resize(i - 1, 4) = dArr
End With
End Sub

Muốn bỏ qua dòng trống thì bạn phải dùng thêm câu lệnh if trong vòng lặp để bẫy rồi đồng thời khai báo thêm biến để xác định dòng dữ liệu để nạp vào mảng kết quả xuất ra

[GPECODE=vb]
Private Sub CommandButton1_Click()
Dim sArr(), dArr(), i As Long, j As Byte, n As Byte, k As Long
With Sheet2
sArr = .Range("G10", .[AI65536].End(3)).Value
ReDim dArr(1 To UBound(sArr), 1 To 4)
For i = 1 To UBound(sArr, 1)
If sArr(i, 1) <> "" Then

k = k + 1
For j = 1 To 4
n = Choose(j, 1, 2, 3, 7)

dArr(k, j) = sArr(i, n)

Next
End If
Next

End With
Sheet1.[B65536].End(3)(2).Resize(k, 4) = dArr
End Sub

[/GPECODE]

VetMini · 19/9/14

@nmhung49:
Người hỏi không nêu rõ ràng điều kiện "dòng trống" có nghĩa là gì. Code của bạn chỉ xét ô đầu tiên trong dòng.
Đối với những người hỏi lơ mơ như vầy, ta chỉ có thể mách đường đi thôi, còn chi tiết code là của họ.

lhthai · 19/9/14

VetMini đã viết:
@nmhung49:
Người hỏi không nêu rõ ràng điều kiện "dòng trống" có nghĩa là gì. Code của bạn chỉ xét ô đầu tiên trong dòng.
Đối với những người hỏi lơ mơ như vầy, ta chỉ có thể mách đường đi thôi, còn chi tiết code là của họ.

Code copy diễn đàn viết lai thoi anh co code nao ngắn chi giup
sao kết quả giống như file la duoc

nmhung49 · 19/9/14

VetMini đã viết:
@nmhung49:
Người hỏi không nêu rõ ràng điều kiện "dòng trống" có nghĩa là gì. Code của bạn chỉ xét ô đầu tiên trong dòng.
Đối với những người hỏi lơ mơ như vầy, ta chỉ có thể mách đường đi thôi, còn chi tiết code là của họ.

Vì thấy có bảng kết quả mong muốn nên đoán là bỏ dòng trống là dòng không có dữ liệu --=0

Em nghĩ bạn ấy cũng muốn học code và ra kết quả là được, em cũng giải thích tay ngang cho bạn ấy hiểu chứ code chủ yếu học từ diễn đàn mà ra.

lhthai · 22/9/14

nmhung49 đã viết:
Muốn bỏ qua dòng trống thì bạn phải dùng thêm câu lệnh if trong vòng lặp để bẫy rồi đồng thời khai báo thêm biến để xác định dòng dữ liệu để nạp vào mảng kết quả xuất ra

[GPECODE=vb]
Private Sub CommandButton1_Click()
Dim sArr(), dArr(), i As Long, j As Byte, n As Byte, k As Long
With Sheet2
sArr = .Range("G10", .[AI65536].End(3)).Value
ReDim dArr(1 To UBound(sArr), 1 To 4)
For i = 1 To UBound(sArr, 1)
If sArr(i, 1) <> "" Then

k = k + 1
For j = 1 To 4
n = Choose(j, 1, 2, 3, 7)

dArr(k, j) = sArr(i, n)

Next
End If
Next

End With
Sheet1.[B65536].End(3)(2).Resize(k, 4) = dArr
End Sub

[/GPECODE]

BẠn có thể bổ sung thêm cột AC được không
Cám ơn bạn nha

lhthai · 24/9/14

Nhờ các Anh xem code em sai cho nào
Hiện tại mình làm copy 1 sheet qua sheet(Data) thì đươc nhưng copy tất cả thì không được

Mã:

Private Sub CommandButton1_Click()
Dim Ws As Worksheet, sArr(), dArr(), i As Long, j As Byte, n As Byte, k As Long, m As Long
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "Data" Then
With Ws
   sArr = .Range("G10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
    If sArr(i, 1) <> "" Then
      k = k + 1
      For j = 1 To 4
         n = Choose(j, 1, 2, 3, 7)
         dArr(k, j) = sArr(i, n)
      Next
    End If
   Next
Sheet1.[B65536].End(3)(2).Resize(k, 4) = dArr
sArr = .Range("AC10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
    If sArr(i, 1) <> "" Then
      m = m + 1
      For j = 1 To 4
         n = Choose(j, 1, 2, 3, 7)
         dArr(m, j) = sArr(i, n)
      Next
    End If
   Next
   Sheet1.[B65536].End(3)(1).Offset(1, 0).Resize(m, 4) = dArr
End With
End If
Next Ws
End Sub

hungpecc1 · 24/9/14

lhthai đã viết:

Nhờ các Anh xem code em sai cho nào
Hiện tại mình làm copy 1 sheet qua sheet(Data) thì đươc nhưng copy tất cả thì không được

Mã:

Private Sub CommandButton1_Click()
Dim Ws As Worksheet, sArr(), dArr(), i As Long, j As Byte, n As Byte, k As Long, m As Long
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "Data" Then
With Ws
   sArr = .Range("G10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
    If sArr(i, 1) <> "" Then
      k = k + 1
      For j = 1 To 4
         n = Choose(j, 1, 2, 3, 7)
         dArr(k, j) = sArr(i, n)
      Next
    End If
   Next
Sheet1.[B65536].End(3)(2).Resize(k, 4) = dArr
sArr = .Range("AC10", .[AI65536].End(3)).Value
   ReDim dArr(1 To UBound(sArr), 1 To 4)
   For i = 1 To UBound(sArr, 1)
    If sArr(i, 1) <> "" Then
      m = m + 1
      For j = 1 To 4
         n = Choose(j, 1, 2, 3, 7)
         dArr(m, j) = sArr(i, n)
      Next
    End If
   Next
   Sheet1.[B65536].End(3)(1).Offset(1, 0).Resize(m, 4) = dArr
End With
End If
Next Ws
End Sub

Sau mỗi lần lặp bạn phải đưa giá trị k, m = 0

Mã:

k = 0: m = 0
Next Ws
End Sub

Lưu ý : kết quả đúng sai là do bạn, mình chỉ làm cho code hết lỗi thôi

lhthai · 24/9/14

Hỏi code lộc dữ liệu AdvancedFilter
Chỉnh vùng điều kiện Range("I3:N4") thành Range("I3:N10") thì không lọc được anh nào biết sai chỗ nào không

Mã:

[TABLE="width: 72"]
[TR]
[TD="width: 72"][COLOR=#0000ff]Private Sub  CommandButton1_Click()[/COLOR][/TD]
[/TR]
[TR]
[TD][COLOR=#0000ff]     Sheet1.Range("A3:F1000").AdvancedFilter xlFilterCopy,  Range("I3:[/COLOR][COLOR=#ff0000]N4[/COLOR][COLOR=#0000ff]"), Range("P4:U4")
End sub[/COLOR][/TD]
[/TR]
[/TABLE]

lhthai · 25/9/14

Bài này đã được anh Cá ngừ F1 giải rồi

Mã:

[/FONT][/COLOR]Private Sub CommandButton1_Click()
    Sheet1.Range("A3:F1000").AdvancedFilter xlFilterCopy, [I3].CurrentRegion, Range("P4:U4")
End Sub

boydaigai · 25/9/14

Sổ chi tiết khách hàng này e tìm đc từ diễn đàn. E muốn học code nên đã tạo sổ cái các tài khoản lập trong sheet1

Private Sub test()Dim arr, arrkq
Dim i, j, erow As Long
Dim stk As Long
stk = Sheet5.Range(

sealand · 25/9/14

Bạn sửa 1 chút cho hoạt hơn về dữ liệu:

Mã:

Sub test()
Dim arr, arrkq
Dim i, j, erow As Long
Dim stk As Long
 stk = Sheet5.Range("C4").Value
 erow = Sheet1.Range("A65000").Row
arr = Sheet1.Range("A9:H" & erow).Value
ReDim arrkq(1 To 200, 1 To 6)
   For i = 1 To UBound(arr)
      [COLOR=#ff0000]If arr(i, 6) Like stk & "*" Then[/COLOR]
         j = j + 1
           arrkq(j, 1) = arr(i, 3)
           arrkq(j, 2) = arr(i, 4)
           arrkq(j, 3) = arr(i, 5)
           arrkq(j, 4) = arr(i, 7)
           arrkq(j, 5) = arr(i, 8)
           End If
     [COLOR=#ff0000] If arr(i, 7) Like stk & "*" Then[/COLOR]
         j = j + 1
           arrkq(j, 1) = arr(i, 3)
           arrkq(j, 2) = arr(i, 4)
           arrkq(j, 3) = arr(i, 5)
           arrkq(j, 4) = arr(i, 6)
           arrkq(j, 6) = arr(i, 8)
      End If
   Next i
[COLOR=#ff0000]If j > 0 Then[/COLOR] Sheet5.Range("A11").Resize(j, 6) = arrkq
Exit Sub: Erase arr(), arrkq()

End Sub

boydaigai · 25/9/14

Option ExplicitDim endR

Hoàng Trọng Nghĩa · 25/9/14

boydaigai đã viết:
Đây là code sổ chi tiết của tác giả (file phía trên) đoạn e bôi đỏ . tham số k có ý nghĩa j và đoạn code bôi đỏ đó có tác dụng j, e ko hiểu nên ko vận dụng cách của tác giả đc

Code trên có các biến được khai báo: Dim endR&, fD&, eD&, i&, s&, k&

Chỉ mỗi biến k là có trong câu hỏi của bạn, còn các biến khác mà tôi tô đỏ trong bài của bạn là biến ở đâu vậy bạn? @#!^%

boydaigai · 25/9/14

Theo e hiểu thì i,s là hàng, k là cột mà tại sao lại là 1 to 4 - - - - - - - - - E ko hiểu k đóng vai trò j trong bài này e mới hỏi mà $-\\/.$

Hoàng Trọng Nghĩa · 25/9/14

boydaigai đã viết:
Theo e hiểu thì i,s là hàng, k là cột mà tại sao lại là 1 to 4 E ko hiểu k đóng vai trò j trong bài này e mới hỏi mà $-\\/.$

Nói như vậy mà không hiểu thì hiểu sao được code trời! Viết bài đừng có dùng những ngôn từ chat vào đây nhé! Nhiều người rất dị ứng!

y_minh · 26/9/14

Code VBA để link dữ liệu từ nhiều file đuổi csv vào một file excel

ndu96081631 đã viết:
Topic Những câu hỏi về code, xin giải thích các code... đã quá dài nên mình đóng nó lại và mở topic khác
Tất cả những bài viết liên quan đến việc nhờ giải thích, xử lý và gỡ rối code VBA, các bạn vui lòng đăng tại đây!
Cảm ơn

Hi các anh chị
Em đang có đề tài không biết xử lý như thế nào. Mong các anh chị giúp đỡ. Em có một phần mềm tự động xuất dữ liệu một mã hàng ra một file csv (file name: tên của đơn hàng.csv). Một ngày có khoảng 30 file csv được xuất ra. Em muốn tổng hợp dữ liệu này một cách tự động từ file csv sang một file excel duy nhât. Nghĩa là mỗi lần có một file csv được tạo ra thì file excel sẽ tự động cập nhất. File csv chứa dữ liệu bề dày của nguyên liệu . Một dòng là bể dày của 1 lot (đo > 10 lần).
Vd:
1.3 2.1 1.5 1.6 1.7 1.8 1.9 2.3
2 2.4 1.7 2.0 2.4 1.9 2.3 2.0
........
File excel của em gồm nhiều cột. Trong đó em dự định cập nhật tự động file như sau
- Model : file name của file csv
- Bề dày mạ (10 điểm): một dòng là một dòng dữ liệu tương ứng trên file csv.
Có anh chị nào có thể giúp em viết code VBA được không ạ.

Kiều Mạnh · 4/10/14

Mình có viết một code Dic lọc duy nhất xuất kết quả ra đúng như mong muốn . nhưng khi mình thử xoá hết dữ liệu vùng nguon đi thì chạy code không có dữ liệu thì nó lấy luôn Tiêu đề vùng nguồn qua không biết mình làm sai chỗ nào mong các bạn chỉ giúp
xin cảm ơn

PHP:

Sub LocDuyNhat()
Dim nguon(), KQ(1 To 65536, 1 To 2), i As Long, k As Long
With ActiveSheet
    nguon = .Range(.[C4], .[C65536].End(3)).Resize(, 2).Value
With CreateObject("scripting.dictionary")
    For i = 1 To UBound(nguon, 1)
        If Not .exists(nguon(i, 1)) Then
            .Add nguon(i, 1), ""
            If nguon(i, 2) <> "" Then
                k = k + 1
                KQ(k, 1) = nguon(i, 1)
                KQ(k, 2) = nguon(i, 2)
            End If
        End If
    Next i
End With
[G4:H65536].ClearContents
[G4].Resize(k, 2) = KQ
End With
End Sub

Hoàng Trọng Nghĩa · 4/10/14

kieu manh đã viết:
Mình có viết một code Dic lọc duy nhất xuất kết quả ra đúng như mong muốn . nhưng khi mình thử xoá hết dữ liệu vùng nguon đi thì chạy code không có dữ liệu thì nó lấy luôn Tiêu đề vùng nguồn qua không biết mình làm sai chỗ nào mong các bạn chỉ giúp
xin cảm ơn

PHP:

Sub LocDuyNhat() Dim nguon(), KQ(1 To 65536, 1 To 2), i As Long, k As Long With ActiveSheet nguon = .Range(.[C4], .[C65536].End(3)).Resize(, 2).Value With CreateObject("scripting.dictionary") For i = 1 To UBound(nguon, 1) If Not .exists(nguon(i, 1)) Then .Add nguon(i, 1), "" If nguon(i, 2) <> "" Then k = k + 1 KQ(k, 1) = nguon(i, 1) KQ(k, 2) = nguon(i, 2) End If End If Next i End With [G4:H65536].ClearContents [G4].Resize(k, 2) = KQ End With End Sub

Thử với cái này:

Mã:

Sub LocDuyNhat()
    Dim LastRow As Long
    LastRow = Range("C65536").End(3)
    If LastRow < 4 Then Exit Sub
    Dim Nguon(), KQ(1 To 65536, 1 To 2), i As Long, k As Long
    Nguon = Range("C4:D" & LastRow)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(Nguon, 1)
            If Not .Exists(Nguon(i, 1)) Then
                .Add Nguon(i, 1), ""
                If Nguon(i, 2) <> "" Then
                    k = k + 1
                    KQ(k, 1) = Nguon(i, 1)
                    KQ(k, 2) = Nguon(i, 2)
                End If
            End If
        Next i
    End With
    Range("G4:H65536").ClearContents
    Range("G4").Resize(k, 2) = KQ
End Sub

ndu96081631 · 4/10/14

kieu manh đã viết:
Mình có viết một code Dic lọc duy nhất xuất kết quả ra đúng như mong muốn . nhưng khi mình thử xoá hết dữ liệu vùng nguon đi thì chạy code không có dữ liệu thì nó lấy luôn Tiêu đề vùng nguồn qua không biết mình làm sai chỗ nào mong các bạn chỉ giúp
xin cảm ơn

PHP:

Sub LocDuyNhat() Dim nguon(), KQ(1 To 65536, 1 To 2), i As Long, k As Long With ActiveSheet nguon = .Range(.[C4], .[C65536].End(3)).Resize(, 2).Value With CreateObject("scripting.dictionary") For i = 1 To UBound(nguon, 1) If Not .exists(nguon(i, 1)) Then .Add nguon(i, 1), "" If nguon(i, 2) <> "" Then k = k + 1 KQ(k, 1) = nguon(i, 1) KQ(k, 2) = nguon(i, 2) End If End If Next i End With [G4:H65536].ClearContents [G4].Resize(k, 2) = KQ End With End Sub

Nếu là tôi viết thì tôi làm vầy:

Mã:

Sub LocDuyNhat1()
  Dim nguon(), KQ(1 To 65536, 1 To 2), i As Long, k As Long
  [COLOR=#ff0000]Dim tmp1 As String, tmp2 As String[/COLOR]
  [COLOR=#ff0000]nguon = ActiveSheet.Range("C4:D10000").Value[/COLOR][COLOR=#006400] ''<--- Khai báo vùng dữ liệu thật to, khỏi End(xlUp) gì ráo[/COLOR]
  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(nguon, 1)
      [COLOR=#ff0000]tmp1 = CStr(nguon(i, 1))
      tmp2 = CStr(nguon(i, 2))[/COLOR]
      [COLOR=#ff0000]If Len(tmp1) Then  [/COLOR][COLOR=#006400]''<--- Nếu cột 1 khác rổng thì đi tiếp[/COLOR][COLOR=#ff0000]
        If Len(tmp2) Then[/COLOR][COLOR=#ff0000]  [/COLOR][COLOR=#006400]''<--- Nếu cột 2 khác rổng thì đi tiếp[/COLOR]
          If Not .Exists(tmp1) Then
            .Add tmp1, ""
            k = k + 1
            KQ(k, 1) = tmp1
            KQ(k, 2) = tmp2
          End If
        End If
      End If
    Next i
  End With
  [G4:H65536].ClearContents
 [COLOR=#ff0000] If k Then[/COLOR] [G4].Resize(k, 2) = KQ    [COLOR=#006400]''<--- Nếu không lọc ra được gì thì... nghỉ khỏe[/COLOR]
End Sub

Chỗ màu đỏ là những chỗ thêm vào
- Tôi thường hiếm khi dùng End(xlUp) <--- Phiền phức (như bạn đã gặp) hoặc trường hợp dữ liệu bị Filter thì End(xlUp) cũng cho kết quả sai
- Đoạn If k Then cuối cùng để chắc rằng: Nếu không có gì để lọc (tức k=0) thì không làm gì cả

Kiều Mạnh · 4/10/14

ndu96081631 đã viết:

Nếu là tôi viết thì tôi làm vầy:

Mã:

Sub LocDuyNhat1()
  Dim nguon(), KQ(1 To 65536, 1 To 2), i As Long, k As Long
  [COLOR=#ff0000]Dim tmp1 As String, tmp2 As String[/COLOR]
  [COLOR=#ff0000]nguon = ActiveSheet.Range("C4:D10000").Value[/COLOR][COLOR=#006400] ''<--- Khai báo vùng dữ liệu thật to, khỏi End(xlUp) gì ráo[/COLOR]
  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(nguon, 1)
      [COLOR=#ff0000]tmp1 = CStr(nguon(i, 1))
      tmp2 = CStr(nguon(i, 2))[/COLOR]
      [COLOR=#ff0000]If Len(tmp1) Then  [/COLOR][COLOR=#006400]''<--- Nếu cột 1 khác rổng thì đi tiếp[/COLOR][COLOR=#ff0000]
        If Len(tmp2) Then[/COLOR][COLOR=#ff0000]  [/COLOR][COLOR=#006400]''<--- Nếu cột 2 khác rổng thì đi tiếp[/COLOR]
          If Not .Exists(tmp1) Then
            .Add tmp1, ""
            k = k + 1
            KQ(k, 1) = tmp1
            KQ(k, 2) = tmp2
          End If
        End If
      End If
    Next i
  End With
  [G4:H65536].ClearContents
 [COLOR=#ff0000] If k Then[/COLOR] [G4].Resize(k, 2) = KQ    [COLOR=#006400]''<--- Nếu không lọc ra được gì thì... nghỉ khỏe[/COLOR]
End Sub

Chỗ màu đỏ là những chỗ thêm vào
- Tôi thường hiếm khi dùng End(xlUp) <--- Phiền phức (như bạn đã gặp) hoặc trường hợp dữ liệu bị Filter thì End(xlUp) cũng cho kết quả sai
- Đoạn If k Then cuối cùng để chắc rằng: Nếu không có gì để lọc (tức k=0) thì không làm gì cả

Cảm Ơn Anh nhiều ... Em Học thêm được một cách viết hay

Hoàng Trọng Nghĩa · 4/10/14

ndu96081631 đã viết:
Nếu là tôi viết thì tôi làm vầy:

Mã:

[COLOR=#ff0000]nguon = ActiveSheet.Range("C4:D10000").Value[/COLOR][COLOR=#006400] ''<--- Khai báo vùng dữ liệu thật to, khỏi End(xlUp) gì ráo[/COLOR]

Tác giả muốn thử xem, nếu không có dữ liệu thì code sẽ làm gì, nếu "chơi" một đống hàng như thế, phải chăng là dù có, dù không dữ liệu thì code vẫn hoạt động, đồng thời, vòng lặp vẫn chạy 10 ngàn lần hay không? Tại sao không ngăn chặn ngay từ đầu vấn đề này khi dữ liệu không có? Khi dữ liệu ít thì code chạy ít đi?

Mã:

Sub LocDuyNhat()
    Dim LastRow As Long, MaxRow As Long
[COLOR=#0000ff]    ''Tinh so hang lon nhat:[/COLOR]
    MaxRow = Rows.Count
    With ActiveSheet [COLOR=#0000ff]''<-- Co the thay bang ten sheet khac[/COLOR]
[COLOR=#0000ff]        ''Loai bo AutoFilter:[/COLOR]
        .AutoFilterMode = False
[COLOR=#0000ff]       ''Tim hang cuoi:[/COLOR]
        LastRow = .Range("C" & MaxRow).End(xlUp)
[COLOR=#ff0000]       ''Neu hang cuoi nho hon hang tieu de thi thoat[/COLOR]
        If LastRow < 4 Then Exit Sub
        Dim Nguon, KQ
        Dim i As Long, k As Long
        Dim Tmp1 As String, Tmp2 As String
        Nguon = .Range("C4:D" & LastRow)
        ReDim KQ(1 To MaxRow, 1 To 2)
        With CreateObject("scripting.dictionary")
            For i = 1 To UBound(Nguon)
                Tmp1 = CStr(Nguon(i, 1))
                Tmp2 = CStr(Nguon(i, 2))
[COLOR=#0000ff]               ''Ca 2 phai khac rong moi chap nhan:[/COLOR]
                If Tmp1 > "" And Tmp1 > "" Then
                    If Not .Exists(Tmp1) Then
                        .Add Tmp1, Empty
                        k = k + 1
                        KQ(k, 1) = Tmp1
                        KQ(k, 2) = Tmp2
                    End If
                End If
            Next i
        End With
        .Range("G4:H" & MaxRow).ClearContents
        If k Then .Range("G4").Resize(k, 2) = KQ
    End With
End Sub

ndu96081631 · 4/10/14

Hoàng Trọng Nghĩa đã viết:
Tác giả muốn thử xem, nếu không có dữ liệu thì code sẽ làm gì, nếu "chơi" một đống hàng như thế, phải chăng là dù có, dù không dữ liệu thì code vẫn hoạt động, đồng thời, vòng lặp vẫn chạy 10 ngàn lần hay không? Tại sao không ngăn chặn ngay từ đầu vấn đề này khi dữ liệu không có? Khi dữ liệu ít thì code chạy ít đi?

Bởi vậy tôi mới nói: "Nếu là tôi viết thì tôi làm vầy"
Tức đó là sở thích riêng của tôi thôi, ai thích khác thì cứ làm khác
Với lại 10000 lần lập cho trường hợp này chỉ là cái nháy mắt, tôi không cảm thấy có việc gì cần quá mức đến nỗi phải lằng nhằng thêm cho mất công
Ẹc... Ẹc...

Hoàng Trọng Nghĩa · 4/10/14

ndu96081631 đã viết:
Bởi vậy tôi mới nói: "Nếu là tôi viết thì tôi làm vầy"
Tức đó là sở thích riêng của tôi thôi, ai thích khác thì cứ làm khác
Với lại 10000 lần lập cho trường hợp này chỉ là cái nháy mắt, tôi không cảm thấy có việc gì cần quá mức đến nỗi phải lằng nhằng thêm cho mất công
Ẹc... Ẹc...

Giỡn chơi hoài Thầy, 10k dòng và nếu với vài chục cột mà chuyển thành mảng cũng khá mất thời gian đó, thêm việc chạy vòng lặp nữa thì cũng ngốn bộ nhớ tạm hơi nhiều đó chứ! Sau đó trước khi End Sub, một lần nữa nó giải phóng cái biến mảng đó cũng ngốn đi một khoảng thời gian nữa. Theo em thì nên tỉ mỉ một chút vẫn thấy bộ nhớ nó "thong thả" hơn.

Vả lại, khi ta đặt cố định hàng như thế, một ngày nào đó số lượng dữ liệu nhiều hơn giá trị ban đầu đó thì rắc rối lại đến với việc xử lý dữ liệu, chắc chắn là không đúng.

ndu96081631 · 4/10/14

Hoàng Trọng Nghĩa đã viết:
Giỡn chơi hoài Thầy, 10k dòng và nếu với vài chục cột mà chuyển thành mảng cũng khá mất thời gian đó

Ngộ hen! 10000 lần lập thì là 10000 lần thôi, liên quan gì đến số cột nhỉ? 100 cột hay 1 cột mà tôi muốn nó 10000 lần lập thì nó cũng chỉ chạy 10000 lần thôi, có vấn đề gì chứ?
-----------------------------

Hoàng Trọng Nghĩa đã viết:
Vả lại, khi ta đặt cố định hàng như thế, một ngày nào đó số lượng dữ liệu nhiều hơn giá trị ban đầu đó thì rắc rối lại đến với việc xử lý dữ liệu, chắc chắn là không đúng.

Tôi đã nói là "sở thích riêng của tôi" rồi mà
Dữ liệu của tôi bao nhiêu tôi tự biết, chắc chắn sẽ không có bất cứ rắc rối gì
Yên tâm nhé!
---------------

Kiều Mạnh · 4/10/14

Hoàng Trọng Nghĩa đã viết:

Tác giả muốn thử xem, nếu không có dữ liệu thì code sẽ làm gì, nếu "chơi" một đống hàng như thế, phải chăng là dù có, dù không dữ liệu thì code vẫn hoạt động, đồng thời, vòng lặp vẫn chạy 10 ngàn lần hay không? Tại sao không ngăn chặn ngay từ đầu vấn đề này khi dữ liệu không có? Khi dữ liệu ít thì code chạy ít đi?

Mã:

Sub LocDuyNhat()
    Dim LastRow As Long, MaxRow As Long
[COLOR=#0000ff]    ''Tinh so hang lon nhat:[/COLOR]
    MaxRow = Rows.Count
    With ActiveSheet [COLOR=#0000ff]''<-- Co the thay bang ten sheet khac[/COLOR]
[COLOR=#0000ff]        ''Loai bo AutoFilter:[/COLOR]
        .AutoFilterMode = False
[COLOR=#0000ff]       ''Tim hang cuoi:[/COLOR]
        LastRow = .Range("C" & MaxRow).End(xlUp)
[COLOR=#ff0000]       ''Neu hang cuoi nho hon hang tieu de thi thoat[/COLOR]
        If LastRow < 4 Then Exit Sub
        Dim Nguon, KQ
        Dim i As Long, k As Long
        Dim Tmp1 As String, Tmp2 As String
        Nguon = .Range("C4:D" & LastRow)
        ReDim KQ(1 To MaxRow, 1 To 2)
        With CreateObject("scripting.dictionary")
            For i = 1 To UBound(Nguon)
                Tmp1 = CStr(Nguon(i, 1))
                Tmp2 = CStr(Nguon(i, 2))
[COLOR=#0000ff]               ''Ca 2 phai khac rong moi chap nhan:[/COLOR]
                If Tmp1 > "" And Tmp1 > "" Then
                    If Not .Exists(Tmp1) Then
                        .Add Tmp1, Empty
                        k = k + 1
                        KQ(k, 1) = Tmp1
                        KQ(k, 2) = Tmp2
                    End If
                End If
            Next i
        End With
        .Range("G4:H" & MaxRow).ClearContents
        If k Then .Range("G4").Resize(k, 2) = KQ
    End With
End Sub

Hình như Nghĩa viết xong rồi chưa chạy thử thì phải code bài 377 và bài này mình chạy thử cả hai thấy báo lỗi...

Hoàng Trọng Nghĩa · 4/10/14

kieu manh đã viết:
Hình như Nghĩa viết xong rồi chưa chạy thử thì phải code bài 377 và bài này mình chạy thử cả hai thấy báo lỗi...

Sorry, tôi viết mà không thử, bạn sửa lại chỗ này:

LastRow = .Range("C" & MaxRow).End(xlUp)

Thành:

LastRow = .Range("C" & MaxRow).End(xlUp).Row

Mã:

Sub LocDuyNhat()
    Dim LastRow As Long, MaxRow As Long
    ''Tinh so hang lon nhat:
    MaxRow = Rows.Count
    With ActiveSheet ''<-- Co the thay bang ten sheet khac
        ''Loai bo AutoFilter:
        .AutoFilterMode = False
       ''Tim hang cuoi:
        LastRow = .Range("C" & MaxRow).End(xlUp)[COLOR=#ff0000][B].Row[/B][/COLOR]
       ''Neu hang cuoi nho hon hang tieu de thi thoat
        If LastRow < 4 Then Exit Sub
        Dim Nguon, KQ
        Dim i As Long, k As Long
        Dim Tmp1 As String, Tmp2 As String
        Nguon = .Range("C4:D" & LastRow)
        ReDim KQ(1 To MaxRow, 1 To 2)
        With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(Nguon)
                Tmp1 = CStr(Nguon(i, 1))
                Tmp2 = CStr(Nguon(i, 2))
               ''Ca 2 phai khac rong moi chap nhan:
                If Tmp1 > "" And [B][COLOR=#ff0000]Tmp2 [/COLOR][/B]> "" Then
                    If Not .Exists(Tmp1) Then
                        .Add Tmp1, Empty
                        k = k + 1
                        KQ(k, 1) = Tmp1
                        KQ(k, 2) = Tmp2
                    End If
                End If
            Next i
        End With
        .Range("G4:H" & MaxRow).ClearContents
        If k Then .Range("G4").Resize(k, 2) = KQ
    End With
End Sub

VetMini · 4/10/14

Hoàng Trọng Nghĩa đã viết:
... trước khi End Sub, một lần nữa nó giải phóng cái biến mảng đó cũng ngốn đi một khoảng thời gian nữa. ...

Từ hồi tôi biết VBA tới giờ, tôi chỉ đoán mò là nó giải phóng mảng bằng cách tương tự như Java, tức là biến chỉ cần ra khỏi phạm vi (exit sub) thì vùng nhớ tự nhiên được nhả ra, và cổ máy gom rác (garbage collection) tự động gom nó trả về cho heap.
Có lẽ trên thực tế, VBA sử dụng bộ nhớ theo cách khác?

Hoàng Trọng Nghĩa · 4/10/14

VetMini đã viết:
Từ hồi tôi biết VBA tới giờ, tôi chỉ đoán mò là nó giải phóng mảng bằng cách tương tự như Java, tức là biến chỉ cần ra khỏi phạm vi (exit sub) thì vùng nhớ tự nhiên được nhả ra, và cổ máy gom rác (garbage collection) tự động gom nó trả về cho heap.
Có lẽ trên thực tế, VBA sử dụng bộ nhớ theo cách khác?

Anh cũng có thể tự làm thí nghiệm mà. Khi kết thúc với End hay Exit Sub/ Function thì mọi biến sẽ được giải phóng, trừ các biến đặt ở ngoài Sub/ Function hoặc các biến là đối số được khai báo bởi ByRef hoặc biến được khai bởi Static.

VetMini · 5/10/14

Theo lý thuyết lập trình, khi biến ra khỏi phạm vi (chấm dứt vùng tầm vực, theo ngôn ngữ của Trần Thanh Phong, trong bài nói về biến) thì biến coi như được xoá sổ.

Theo kiến thức của tôi về VBA thì đó là chấm dứt nhiệm vụ của chương trình đối với vùng nhớ mà VBA giành cho biến. Việc đem vùng nhớ trả về cho vùng nhớ chung (heap memory) là công việc của cổ máy garbage collection. Cũng theo kiến thức giới hạn của tôi thì cỏ máy này khá đơn giản, chỉ làm việc bằng cách đếm references. Khi biến không sử dụng vùng nhớ nữa thì nó trừ reference đi 1. Khi số references về đến ze rô thì garbage collection coi như vùng nhớ hiện không thuộc về biến nào cả và có thể gom được. Như vậy việc biến nhả vùng nhớ chỉ xảy ra trong vòng vài lệnh máy - tức là vài phần tỷ giây. Không xứng đáng phải quan tâm. Chỉ có công việc lấy vùng nhớ cho mảng (memory allocation) mới phức tạp hơn một chút. Nhưng cũng rất nhanh, kỹ thuật này được viết bằng các hàm macro máy (assembly macro) nên rất hiệu quả.

Hoàng Trọng Nghĩa · 6/10/14

VetMini đã viết:
Theo lý thuyết lập trình, khi biến ra khỏi phạm vi (chấm dứt vùng tầm vực, theo ngôn ngữ của Trần Thanh Phong, trong bài nói về biến) thì biến coi như được xoá sổ.

Theo kiến thức của tôi về VBA thì đó là chấm dứt nhiệm vụ của chương trình đối với vùng nhớ mà VBA giành cho biến. Việc đem vùng nhớ trả về cho vùng nhớ chung (heap memory) là công việc của cổ máy garbage collection. Cũng theo kiến thức giới hạn của tôi thì cỏ máy này khá đơn giản, chỉ làm việc bằng cách đếm references. Khi biến không sử dụng vùng nhớ nữa thì nó trừ reference đi 1. Khi số references về đến ze rô thì garbage collection coi như vùng nhớ hiện không thuộc về biến nào cả và có thể gom được. Như vậy việc biến nhả vùng nhớ chỉ xảy ra trong vòng vài lệnh máy - tức là vài phần tỷ giây. Không xứng đáng phải quan tâm. Chỉ có công việc lấy vùng nhớ cho mảng (memory allocation) mới phức tạp hơn một chút. Nhưng cũng rất nhanh, kỹ thuật này được viết bằng các hàm macro máy (assembly macro) nên rất hiệu quả.

Em thì chả có học cao siêu gì, nhưng nếu thí nghiệm trên một sheet mà dữ liệu đủ lớn để thấy được thời gian nhận biến và giải phóng biến thì dùng code này sẽ thấy có một sự chênh lệch về thời gian, do đâu? Phải chăng là thời gian nó giải phóng biến?

Mã:

Option Explicit
Dim T As Double


Sub TestTime1()
    T = Timer
    Dim Arr()
    Arr = Sheet1.UsedRange.Value
    Debug.Print Timer - T
End Sub


Sub TestTime2()
    TestTime1
    Debug.Print Timer - T
End Sub

VetMini · 6/10/14

Test Timer như vậy chưa hẳn đã chính xác. Theo nguyên tắc tính thời gian, nguoiwf ta cho code chạy khoảng vài trăm vòng và lập biểu đồ thống kê kết quả. Nói chung thì cuối cùng code sẽ có một điểm bảo hoà.

Tuy nhiên, để diễn tả cho bạn thấy rằng timer không chính xác để đo tốc độ chạy của code. Tôi thử code sau:

Function ftt() As Single
Dim Arr()
Arr = Sheet1.UsedRange.Value
ftt = Timer
End Function

Sub stt()
Dim i As Integer
For i = 1 To 100: Debug.Print ftt - Timer; Timer - ftt: Next i
End Sub

Theo lý thuyết thì kết quả ở mỗi dòng in ra, trị thứ nhất và trị thứ hai phải gần giống nhau. Trên thực tế thì khác hẳn.

(*) timer là single chứ không phải double. Nhưng cái này không quan trọng.

Vô danh Tiểu tốt · 6/10/14

Hoàng Trọng Nghĩa đã viết:
Mã:

Option Explicit Dim T As Double Sub TestTime1() T = Timer Dim Arr() Arr = Sheet1.UsedRange.Value Debug.Print Timer - T End Sub Sub TestTime2() TestTime1 Debug.Print Timer - T End Sub

Theo hiểu biết ít ỏi của tôi thì mọi tiến trình hay lệnh được xử lý trong máy tính đều tốn thời gian cả dù thời gian này có khi nhỏ hơn cả 1 mili giây (micro giây). Bởi thế có hay không có giải phóng bộ nhớ thì chỉ mỗi lệnh gán Arr = Sheet1.UsedRange.Value cũng đã tốn 1 khoảng thời gian (dù cực nhỏ).

Ở đây thấy có người đề cập tới Heap, stack.... trong bộ nhớ, những lý thuyết được khá nhiều giáo trình minh họa bằng các vị dú viết bằng ngôn ngữ cấp cao như Pascal, VB... để giúp người đọc có thể hiểu. Tuy nhiên đây chỉ là minh họa. Nếu chúng ta hiểu như thế thì không khác nào những đứa trẻ cứ ngộ rằng các hạt vật chất có dạng hình cầu xanh đỏ như trong hình vẽ minh họa SGK trong khi thực tế chẳng ai biết các hạt đấy hình thù màu sắc thế nào...

Các khái niệm về heap, stack... trong bộ nhớ là những khái niệm khá trừu tượng hay gặp phải khi lập trình các ngôn ngữ cấp thấp như asm, C/C++. Và chúng là những khái niệm làm đau đầu những người viết code thưở xa xưa. Các ngôn ngữ cấp cao sau này điển hình như VB được thiết kế với một trong những mục tiêu là làm sao cho người viết code được quẳng bỏ những lo toan về quản lý bộ nhớ này nọ để dành tâm chí cho các giải thuật thiết thực.

Trừ khi bạn cố gắng quay trở về những heap, stack... của bộ nhớ với các APi thao tác trực tiếp, còn thức tế thì những lý thuyết này không hiện diện trong bất cứ đoạn code nào bạn viết cả, có chăng là nó ẩn sâu trong các mã máy được biên dịch sau cùng và chúng cũng nằm ngoài ý chí chủ quan của bạn.

vacandem · 6/10/14

Em muốn đặt biến m, n là số hàng và số cột của Cell trong excel. Khi dùng Cells(m,n) = xyz thì được nhưng khi dùng với công thức theo kiểu R1C1 thì báo lỗi 1004 "Application defined or object defined". Code em viết thế này:
Dim m, n, sothutu As Long
sothutu = FilterDate.Cells(3, 4)
cotmot = sothutu * 2
cothai = cotmot - 1

Sheets("FilterDate").Select
Range("A6").Select
ActiveCell.FormulaR1C1 = _
"=IF(Ex_Date!R[1]C[cotmot]=FilterDate!R2C3,Ex_Date!R[1]C[1],"""")"
Range("B6").Select
ActiveCell.FormulaR1C1 = _
"=IF(Ex_Date!R[1]C[cothai]=FilterDate!R2C3,Ex_Date!R[1]C[cotmot],"""")"
Em mới học mong các bác chỉ cách dùng đúng ạ

VetMini · 7/10/14

vacandem đã viết:
...
"=IF(Ex_Date!R[1]C[cotmot]=FilterDate!R2C3,Ex_Date!R[1]C[1],"""")"
...
Em mới học mong các bác chỉ cách dùng đúng ạ

"=IF(Ex_Date!R[1]C[" & cotmot & "]=FilterDate!R2C3,Ex_Date!R[1]C[1],"""")"

VetMini · 7/10/14

Vô danh Tiểu tốt đã viết:
... để dành tâm chí cho các giải thuật thiết thực.
...

Định nghĩa thế nào là giải thuật thiết thực?

Ở đây trình độ hầu hết chỉ tới mức sao chép chuyển đổi tom góp dữ liệu. Đâu có ai đạt đến mức đồ án dự án hằng trăm modules, hằng ngàn dòng code như bạn đâu mà cần phải mô hình này nọ.

Vô danh Tiểu tốt · 7/10/14

VetMini đã viết:
Định nghĩa thế nào là giải thuật thiết thực?

Ở đây trình độ hầu hết chỉ tới mức sao chép chuyển đổi tom góp dữ liệu. Đâu có ai đạt đến mức đồ án dự án hằng trăm modules, hằng ngàn dòng code như bạn đâu mà cần phải mô hình này nọ.

Tôi thì không phải người giỏi chữ nghĩa nên chắc dùng từ ngữ ngô ngê chăng? Nếu có gì sai thì vui lòng chỉ bảo.

Hình như trí tuệ của bạn có khả năng hư cấu, thêm thắt và phóng tác thì phải. Chẳng biết lấy dữ kiện đâu ra mà bạn bỗng chốc biến tôi từ một kẻ Vô danh Tiểu tốt mở miệng bằng câu "Theo hiểu biết ít ỏi của tôi" bỗng thành một siêu nhân.

Rất cám ơn bạn vì đã dành cho Vô danh Tiểu tốt tôi những mỹ từ hoàng tráng đó nhưng tôi xin trả lại bạn vì có vẻ là bạn xứng đáng hơn.

gghh · 22/10/14

xin chỉ giúp cải thiện tốc đoạn code sau!

Xin các anh chị chỉ giúp em cách cải thiện tốc độ của đoạn code sau: nếu lặp khoảng 10.000 lần.
Private Sub Check_Click()
Dim i, j As Integer
For i = 1 To 10
For j = i + 1 To 10
If (Cells(i, 2) = Cells(j, 2) And Cells(i, 3) = Cells(j, 3) And Cells(i, 4) = Cells(j, 4)) Then
Cells(i, 2).Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Cells(i, 3).Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Cells(i, 4).Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Cells(j, 2).Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Cells(j, 3).Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Cells(j, 4).Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
End If
Next j
Next i
End Sub

Hau151978 · 22/10/14

Mình không có Excel 2007 để thử property TintAndShade nên mình chỉ đóng góp thế này: bạn đang định dò bảng, nếu có 2 dòng i, j mà các ô cột B, C, D trùng nhau thì sẽ tô màu đỏ các ô này. Theo chương trình bạn làm thì giả sử dòng 1, 2, 3, 4 trùng nhau thì mỗi dòng sẽ tô màu đỏ lặp lại 3 lần làm giảm thời gian. Theo mình, bạn nên insert 1 cột E trống, gán bảng B1:E1000 vào mảng arr(1 to 1000, 1 to 4) sau đó lặp như sau

Mã:

Application.ScreenUpdating=False
For i = 1 to 999
   'nếu arr(i,4)=TRUE tức là hàng i đã tô màu thì next i
   if not arr(i,4) then  
     for j=i+1 to 1000
     'nếu arr(j,4)=TRUE tức là hàng j đã tô màu thì next j  
         if not arr(j,4) and arr(i,1)=arr(j,1) and arr(i,2)=arr(j,2) and arr(i,3)=arr(j,3) then
              if not arr(i,4) then
               'kiểm tra lại xem hàng i đã tô màu trong lần lặp với các giá trị j trước chưa   
                  arr(i,4)=TRUE
                  Range("B" & i, "D" & i).Font.Color=-16776961
                  Range("B" & i, "D" & i).Font.Tintandshade=0
              end if
              arr(j,4)=TRUE
              Range("B" & j, "D" & j).Font.Color=-16776961
              Range("B" & j, "D" & j).Font.Tintandshade=0
         end if
      next j
   end if
next i
Columns(5).delete
Application.ScreenUpdating=True

hoanglocphat · 22/10/14

Các bạn cho tôi hỏi:
Tôi có đọan code đặt trong sheet

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)  Dim rCel As Range, rFind As Range, rSrc As Range, rTarget As Range
  On Error GoTo ExitSub
  If Not Intersect(Range(

hoanglocphat · 23/10/14

hoanglocphat đã viết:
Các bạn cho tôi hỏi:
Tôi có đọan code đặt trong sheet

Mã:

Private Sub Worksheet_Change(ByVal Target As Range) Dim rCel As Range, rFind As Range, rSrc As Range, rTarget As Range On Error GoTo ExitSub If Not Intersect(Range(

Quang_Hải · 23/10/14

hoanglocphat đã viết:
Các bạn giải thích giùm tại sao cái dòng màu đỏ nó kg có tác dụng vậy?
Hoặc các bạn có cách khác nào để mỗi khi chạy code thì File tự động chuyển sang Manual, dù trước đó người dùng đã chuyển sang chế độ Automatic
Cãm ơn các bạn!

Chắc không phải tại dòng code không có tác dụng mà là code bị gì gì đó nên nó chạy tuốt xuống Exit Sub luôn rồi. Mà mình đọc sơ qua code thấy vướng vướng sao ấy.
Kinh nghiệm cho thấy bài hỏi có kèm file thường nhận đáp án nhanh và chính xác.

hoanglocphat · 23/10/14

quanghai1969 đã viết:
Chắc không phải tại dòng code không có tác dụng mà là code bị gì gì đó nên nó chạy tuốt xuống Exit Sub luôn rồi. Mà mình đọc sơ qua code thấy vướng vướng sao ấy.
Kinh nghiệm cho thấy bài hỏi có kèm file thường nhận đáp án nhanh và chính xác.

Cảm ơn bạn đã giúp
Tôi đã kiểm tra lại, nếu chỉ mở 1 file chưa code trên thì dù ở chế độ nào nó vẫn chạy tốt
Chỉ khi nào mở nhiều file có những đọan code khác, hoặc chương trình khác thì mới bị lỗi trên
Code trên là tôi sưu tầm trên GPE, code này là của người siêu về code
Bạn có thể tìm nó ở dưới đường Link sau
http://www.giaiphapexcel.com/forum/...ter-thì-Cell-C10-hiện-tên-hàng-hóa-tương-ứng!

Quang_Hải · 23/10/14

hoanglocphat đã viết:
Cảm ơn bạn đã giúp
Tôi đã kiểm tra lại, nếu chỉ mở 1 file chưa code trên thì dù ở chế độ nào nó vẫn chạy tốt
Chỉ khi nào mở nhiều file có những đọan code khác, hoặc chương trình khác thì mới bị lỗi trên
Code trên là tôi sưu tầm trên GPE, code này là của người siêu về code
Bạn có thể tìm nó ở dưới đường Link sau
http://www.giaiphapexcel.com/forum/...ter-thì-Cell-C10-hiện-tên-hàng-hóa-tương-ứng!

Code không vấn đề gì, vướng vướng là vì không có file sao biết code có suông sẻ hay không. Code phải phù hợp với từng loại dữ liệu chứ. Cho nên phải có file thôi.

minhtungph · 11/11/14

nhờ các bạn giải thích code giúp mình

Mã:

[COLOR=#000000]Dim strCom As String
Dim objWMIService As Object[/COLOR]
[COLOR=#000000]Dim colAdapters As Object[/COLOR]
[COLOR=#000000]Dim objAdapter As Object[/COLOR]
[COLOR=#000000]strCom = "."[/COLOR]
[COLOR=#000000]Set objWMIService = GetObject _[/COLOR]
[COLOR=#000000]("winmgmts:" & "!\\" & strCom & "\root\cimv2")[/COLOR]
[COLOR=#000000]Set colAdapters = objWMIService.ExecQuery _[/COLOR]
[COLOR=#000000]("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")[/COLOR]
[COLOR=#000000]For Each objAdapter In colAdapters[/COLOR]
[COLOR=#000000]Sheets("login").Range("AB25") = objAdapter.MACAddress[/COLOR]
[COLOR=#000000][INDENT]Next objAdapter[/INDENT]
[/COLOR]

công dụng cuối cùng của nó là gán địa chỉ MAC của máy tính cho ô AB25 để dùng những thuật toán mã hóa tạo CDkey nhưng tại sao lại tạo truy vấn và duyệt vòng lập trong đó
Nhân tiện các bạn biết kiểu biến Object có tác dụng gì không ạ, và khi nào mới sử dụng nó, cám ơn các bạn đã đọc bài viết

hungpecc1 · 11/11/14

minhtungph đã viết:
nhờ các bạn giải thích code giúp mình

Mã:

[COLOR=#000000]Dim strCom As String Dim objWMIService As Object[/COLOR] [COLOR=#000000]Dim colAdapters As Object[/COLOR] [COLOR=#000000]Dim objAdapter As Object[/COLOR] [COLOR=#000000]strCom = "."[/COLOR] [COLOR=#000000]Set objWMIService = GetObject _[/COLOR] [COLOR=#000000]("winmgmts:" & "!\\" & strCom & "\root\cimv2")[/COLOR] [COLOR=#000000]Set colAdapters = objWMIService.ExecQuery _[/COLOR] [COLOR=#000000]("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")[/COLOR] [COLOR=#000000]For Each objAdapter In colAdapters[/COLOR] [COLOR=#000000]Sheets("login").Range("AB25") = objAdapter.MACAddress[/COLOR] [COLOR=#000000][INDENT]Next objAdapter[/INDENT] [/COLOR]

công dụng cuối cùng của nó là gán địa chỉ MAC của máy tính cho ô AB25 để dùng những thuật toán mã hóa tạo CDkey nhưng tại sao lại tạo truy vấn và duyệt vòng lập trong đó
Nhân tiện các bạn biết kiểu biến Object có tác dụng gì không ạ, và khi nào mới sử dụng nó, cám ơn các bạn đã đọc bài viết

1- Vòng lặp là để duyệt qua các Adapters của máy bạn ( ví dụ bạn lắp 2 card mạng, hoặc máy bạn có 1 Lan, 1 wifi )
2- Kiểu biến object , tức là biến đó là 1 đối tượng có thuộc tính , phương thức, việc khai báo biến tường minh có lẽ chương trình sẽ chạy nhanh hơn và rõ ràng hơn !

Chuyên mục xử lý, gỡ rối code VBA (1 người xem)

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

Huyền thoại GPE

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

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

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

Đang đi tìm hòn đá

I don't program, I beat code into submission!!!

Thành viên bị đình chỉ hoạt động

File đính kèm

Thành viên mới

Thành viên bị đình chỉ hoạt động

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

Thành viên bị đình chỉ hoạt động

Chuyên gia GPE

Thành viên bị đình chỉ hoạt động

Thành viên bị đình chỉ hoạt động

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

Thành viên mới

Chuyên gia GPE

Chuyên gia GPE

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

Chuyên gia GPE

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

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

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

Chuyên gia GPE

Chuyên gia GPE

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

Chuyên gia GPE

File đính kèm

Chuyên gia GPE

Thành viên mới

Chuyên gia GPE

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

Thành viên gắn bó

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

Thành viên gắn bó

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

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

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

Đang đi tìm hòn đá

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

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

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

Chuyên gia GPE

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

Chuyên gia GPE

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

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

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

Chuyên gia GPE

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

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

Chuyên gia GPE

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

Đang đi tìm hòn đá

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

Đang đi tìm hòn đá

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

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

Đang đi tìm hòn đá

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

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

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

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

Thành viên gắn bó

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

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

Thành viên bị đình chỉ hoạt động

File đính kèm

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

Thành viên bị đình chỉ hoạt động

Chuyên gia GPE

Thành viên bị đình chỉ hoạt động

Chuyên gia GPE