Nhờ sửa lại code này giùm em (1 người xem)

[thanhlong68]

Em có đoạn code trong bài này nhưng không biết sửa thế nào
Nhờ mọi người sửa lại giúp em

 

[Quang_Hải]

Em có đoạn code trong bài này nhưng không biết sửa thế nào
Nhờ mọi người sửa lại giúp em

Code sai hết. Không thể sửa vì không biết bạn cần gì.
If Sheet1 là cái quái gì trong code?

 

[thanhlong68]

If Rng(I, 4) > 0 Then

đây là cái em cần anh ạ

 

[thanhlong68]

Ý em hỏi tại sao khi viết nội dung vào cột D sau khi chạy code nó sẽ bị mất
Có cách nào sửa lại để khi chạy code nó vẫn giữ nguyên được không ạ

 

[Quang_Hải]

Ý em hỏi tại sao khi viết nội dung vào cột D sau khi chạy code nó sẽ bị mất
Có cách nào sửa lại để khi chạy code nó vẫn giữ nguyên được không ạ

Mất là do đoạn code này

            With Sheet2
               .[A2].Resize(65000, 4).Value = Arr
               .[A2].Resize(k, 4).Borders.Weight = xlThin
           End With

Số 4 tức là thay hết dữ liệu từ cột A đến cột D.

 

[thanhlong68]

Nhưng không có đoạn này thì sẽ không lọc ra được anh ạ, anh có thể giúp em làm sao vẫn ra kết quả mà không bị mất được không anh?

 

[Quang_Hải]

Nhưng không có đoạn này thì sẽ không lọc ra được anh ạ, anh có thể giúp em làm sao vẫn ra kết quả mà không bị mất được không anh?

Với cái file đó bạn muốn lọc kiểu gì? Code phải viết lại, không xài code đó được

 

[thanhlong68]

Em muốn lọc như sau:
Nếu ở cột D có ghi chú thì sẽ lấy dữ liệu từ 1 đến 4 và lọc qua sheet 2, và em muốn có ghi chú ở sheet 2 khi chạy code nó sẽ không bị xóa. Em cám ơn anh nhiều

 

[Quang_Hải]

Em muốn lọc như sau:
Nếu ở cột D có ghi chú thì sẽ lấy dữ liệu từ 1 đến 4 và lọc qua sheet 2, và em muốn có ghi chú ở sheet 2 khi chạy code nó sẽ không bị xóa. Em cám ơn anh nhiều

Có ai hiểu bạn muốn lọc kiểu gì hay không chứ mình thì thua rồi. Nếu up lên cái file có dữ liệu mô ta trước và sau khi lọc thì may ra. Lọc theo dk gi? v..v.

 

[thanhlong68]

Em có tải lại file anh xem giùm

 

[hoamattroicoi]

Em muốn lọc như sau:
Nếu ở cột D có ghi chú thì sẽ lấy dữ liệu từ 1 đến 4 và lọc qua sheet 2, và em muốn có ghi chú ở sheet 2 khi chạy code nó sẽ không bị xóa. Em cám ơn anh nhiều

Nội dung cái file này trông quen quá, anh quanghai1969 không hiểu là đúng rùi, tẩu hỏa nhập ma rùi hehehe. Để không mất ghi chú thì bạn chỉnh chỗ này trong code nè :
With Sheet2
.[A2].Resize(65000, 4).Value = Arr
.[A2].Resize(k, 4).Borders.Weight = xlThin
End With

Thành :

With Sheet2
.[A2].Resize(65000, 3).Value = Arr
.[A2].Resize(k, 4).Borders.Weight = xlThin
End With


Chỉnh cái chỗ đỏ đỏ nha bạn, thay vì mở rộng ra 4 cột, bạn mở rộng ra 3 cột thôi nhé! Như thế phần khai báo cho Arr ở trên cũng không cần mở rộng để 10 cột đâu vì bạn chả xài đến 10 cột đó mà chỉ dùng đến 3 cột thôi. Đây chắc là file ví dụ của bạn phải không, còn nếu là file thật của bạn thì chắc chúng ta quen nhau đấy

Còn với file mới bạn sử dụng code này nha :

Sub LocDL()
Dim i As Long, k As Long, j As Long
Dim Arr(), dArr()
Arr = Sheets("sheet1").Range("A2:A" & Sheets("sheet1").[A65536].End(xlUp).Row).Resize(, 4).Value
ReDim dArr(1 To UBound(Arr, 1), 1 To 4)
For i = 1 To UBound(Arr, 1)
    If Arr(i, 4) > 0 Then
        k = k + 1
        For j = 1 To 4
            dArr(k, j) = Arr(i, j)
        Next
    End If
Next i
    Sheets("Sheet2").[A2:D100].ClearContents
    If k Then Sheets("Sheet2").[A2].Resize(k, 4) = dArr
End Sub

 

[Quang_Hải]

Em có tải lại file anh xem giùm

Phải thế này không

Sub loc()
Dim i As Long, j As Long, Sarr(), Result()
With Sheets("sheet1")
   Sarr = .Range(.[A2], .[D65536].End(3)).Resize(, 4).Value
End With
With Sheets("sheet2")
   .[D2:D10000].ClearContents
   Result = .Range(.[A2], .[A65536].End(3)).Resize(, 4).Value
End With
For i = 1 To UBound(Result)
   For j = 1 To UBound(Sarr)
      If Result(i, 1) & Result(i, 2) & Result(i, 3) = Sarr(j, 1) & Sarr(j, 2) & Sarr(j, 3) Then
         Result(i, 4) = Sarr(j, 4)
      End If
   Next
Next
Sheets("sheet2").[A2].Resize(i - 1, 4) = Result
End Sub

 

[ptm0412]

Code dư cả đống dòng, cả đống biến, và Array dư cả đống cột. Sửa lại như sau:

Sub loc()
On Error Resume Next
Dim Rng(), Arr(1 To 65000, 1 To 4), I As Long, k As Long
Dim ws As Worksheet
  For Each ws In Worksheets
    If ws.Name <> "Sheet2" Then
        Rng = ws.Range(ws.[B2], ws.[b65000].End(xlUp)).Offset(, -1).Resize(, 4).Value
        For I = 1 To UBound(Rng, 1)
            If Rng(I, 4) > 0 Then
                k = k + 1
                If k <= 65000 Then
                    Arr(k, 1) = k
                    Arr(k, 2) = Rng(I, 2)
                    Arr(k, 3) = Rng(I, 3)
                    Arr(k, 4) = Rng(I, 4)
                Else
                    MsgBox "Sheet2 is full": Exit For
                End If
            End If
        Next I
    End If
Next ws
With Sheet2
    .[A2].Resize(k, 4).Value = Arr
    .[A2].Resize(k, 4).Borders.Weight = xlThin
End With
k = 0
End Sub

Code này chạy cho nhiều sheet luôn.

 

[thanhlong68]

Vẫn chưa thấy đc anh ạ, code của anh quanghai1969 em không thấy chạy được khi có thêm dữ liệu anh ơi

 

[Quang_Hải]

Vẫn chưa thấy đc anh ạ, code của anh quanghai1969 em không thấy chạy được khi có thêm dữ liệu anh ơi

Bản chất bài toán rất đơn giản, nhưng thật sự mình không hiểu bạn muốn cái gì nên chẳng biết làm sao nữa
Nếu muốn nhanh thì hãy mô tả bảng dư liệu trước khi chạy code và sau khi chạy code nó ra làm sao

 

[thanhlong68]

Em có tải lại file và có ghi rõ trong VD, do em mô tả hơi dài dòng nên khó hiểu, anh quanhai thông cảm nhé

 

[Quang_Hải]

Em có tải lại file và có ghi rõ trong VD, do em mô tả hơi dài dòng nên khó hiểu, anh quanhai thông cảm nhé

Hên xui lần nữa coi sao. Lẽ ra nên làm thủ công cho ra cái bảng kết quả kế bên. Nói vậy mà bạn cũng không hiểu

Sub loc2()
Dim i As Long, j As Long, Sarr(), SResult(), DResult(1 To 10000, 1 To 5), KeyItem, k
With Sheets("sheet1")
   Sarr = .Range(.[A2], .[A65536].End(3)).Resize(, 4).Value
End With
With Sheets("sheet2")
   SResult = .Range(.[A2], .[A65536].End(3)).Resize(, 5).Value
End With
With CreateObject("scripting.dictionary")
For i = 1 To UBound(SResult)
   KeyItem = Val(SResult(i, 1)) & SResult(i, 2) & SResult(i, 3)
   If Not .exists(KeyItem) Then
      k = k + 1
      .Add KeyItem, k
      For j = 1 To 5
         DResult(k, j) = SResult(i, j)
      Next
   End If
Next
For i = 1 To UBound(Sarr)
   KeyItem = Val(Sarr(i, 1)) & Sarr(i, 2) & Sarr(i, 3)
   If Sarr(i, 4) <> "" Then
      If Not .exists(KeyItem) Then
         k = k + 1
         .Add KeyItem, k
         For j = 1 To 4
            DResult(k, j) = Sarr(i, j)
         Next
      End If
   End If
Next
End With
Sheets("sheet2").[A2].Resize(k, 5) = DResult
End Sub

Mới bổ sung thêm hàm Val(). Dữ liệu của bạn 1 bên là số 1 và 1 bên là số 01

 

[thanhlong68]

Đúng rồi anh ơi, cám ơn anh nhiều nhé. phiền anh quá

 

[Quang_Hải]

Đúng rồi anh ơi, cám ơn anh nhiều nhé. phiền anh quá

Xem lai code bài 17, có chỉnh sửa. Có ghi chú ở cuối bài.