Giúp xuất dữ liệu tham chiếu qua 1 cột bằng VBA theo dạng Danh mục (1 người xem)

  • Thread starter Thread starter ohho84
  • Ngày gửi Ngày gửi
Liên hệ QC

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

ohho84

Thành viên chính thức
Tham gia
11/8/11
Bài viết
94
Được thích
2
Xin phép Mod vì em hỏi bằng cách reply trong Topic không có ai trả lời nên em tạo Topic mới ạ. Vấn đề em đã trình bày chi tiết trong file đính kèm. Xin các cao nhân giúp đỡ ạ +-+-+-++-+-+-++-+-+-+
 

File đính kèm

Xin phép Mod vì em hỏi bằng cách reply trong Topic không có ai trả lời nên em tạo Topic mới ạ. Vấn đề em đã trình bày chi tiết trong file đính kèm. Xin các cao nhân giúp đỡ ạ +-+-+-++-+-+-++-+-+-+

Gõ vào ô A1 nha.....................................
 

File đính kèm

Mãi không ai giúp em với ạ :( .
 
Mãi không ai giúp em với ạ :( .

Bạn kiểm tra xem Code này được chưa nha:
Mã:
Sub loc()
Set dic = CreateObject("Scripting.Dictionary")
nguon = Sheets(1).Range("A2:I16")
ReDim kq(1 To 100, 1 To 8)
Sheets(2).[A2:H1000].ClearContents
k = 0
  For i = 1 To UBound(nguon)
    If nguon(i, UBound(nguon, 2)) = Sheets(2).[A1] Then
      k = k + 1
      If nguon(i, 1) = "" Then
         temp = Sheets(1).Range("A" & Sheets(1).Cells(i, 1).End(3).Row)
         If Not dic.exists(temp) Then
           kq(k, 1) = temp
           dic.Add temp, ""
         End If
      Else
         kq(k, 1) = nguon(i, 1)
         dic.Add nguon(i, 1), ""
      End If
      
      For j = 2 To UBound(nguon, 2) - 1
         kq(k, j) = nguon(i, j)
      Next j
    End If
  Next i


   Sheets(2).[A2].Resize(100, 8) = kq
End Sub

Bên trên đã có bài của anh LetGâuGâu giúp rồi còn gì nhỉ ..
 
chạy thử code sau
Mã:
Sub GPE()
Dim Darr, Arr(), Nban As String, i As Long, j As Integer, k As Integer, tmp As String
With Sheets(1)
    Darr = .Range("A2:I" & .Range("B2").End(xlDown).Row + 1)
End With
ReDim Arr(1 To UBound(Darr), 1 To 8)
With Sheets(2)
Nban = .Cells(1, 1)
For i = 1 To UBound(Darr) - 1
    If Darr(i + 1, 1) = "" Then Darr(i + 1, 1) = Darr(i, 1)
    If Darr(i, 9) = Nban Then
        k = k + 1
        For j = 2 To 8
            Arr(k, j) = Darr(i, j)
        Next j
        If tmp <> Darr(i, 1) Then
            Arr(k, 1) = Darr(i, 1)
            tmp = Darr(i, 1)
        End If
    End If
Next i
.Range("A2:H20000").Clear
.Range("A2").Resize(k, 8) = Arr
End With
End Sub
 
Bác sửa lại giùm em theo cách VBA ko tham chiếu qua ô A1 được không ạ. Vì khi em thay A1 bằng text khác nó ko chạy ( Như file & Ảnh em đính kèm ạ )
Bạn kiểm tra xem Code này được chưa nha:
Mã:
Sub loc()
Set dic = CreateObject("Scripting.Dictionary")
nguon = Sheets(1).Range("A2:I16")
ReDim kq(1 To 100, 1 To 8)
Sheets(2).[A2:H1000].ClearContents
k = 0
  For i = 1 To UBound(nguon)
    If nguon(i, UBound(nguon, 2)) = Sheets(2).[A1] Then
      k = k + 1
      If nguon(i, 1) = "" Then
         temp = Sheets(1).Range("A" & Sheets(1).Cells(i, 1).End(3).Row)
         If Not dic.exists(temp) Then
           kq(k, 1) = temp
           dic.Add temp, ""
         End If
      Else
         kq(k, 1) = nguon(i, 1)
         dic.Add nguon(i, 1), ""
      End If
      
      For j = 2 To UBound(nguon, 2) - 1
         kq(k, j) = nguon(i, j)
      Next j
    End If
  Next i


   Sheets(2).[A2].Resize(100, 8) = kq
End Sub

Bên trên đã có bài của anh LetGâuGâu giúp rồi còn gì nhỉ ..
 

File đính kèm

Với lại khi Tab Nhật ký bán hàng em cho dữ liệu nhiều dòng lên thì Tab Người bán A chỉ in ra đến dòng thứ 8 là hết ạ :=\+:=\+:=\+
 
@Hiếu CD : Code bác em thấy chạy ngon nhất ạ nhưng có điều khi in ra dữ liệu thì nó làm xóa đi các style em đã định dạng cho bảng như: Màu background, Fontsize chữ và màu chữ như ảnh em đính kèm đó ạ. Bác có fix được cái này ko bác +-+-+-+
 

File đính kèm

  • 2016-09-08_091723.jpg
    2016-09-08_091723.jpg
    20.6 KB · Đọc: 40
@Hiếu CD : Code bác em thấy chạy ngon nhất ạ nhưng có điều khi in ra dữ liệu thì nó làm xóa đi các style em đã định dạng cho bảng như: Màu background, Fontsize chữ và màu chữ như ảnh em đính kèm đó ạ. Bác có fix được cái này ko bác +-+-+-+
sửa code
Mã:
Sub GPE()
Dim Darr, Arr(), Nban As String, i As Long, j As Integer, k As Integer, tmp As String
With Sheets(1)
    Darr = .Range("A2:I" & .Range("B2").End(xlDown).Row + 1)
End With
ReDim Arr(1 To UBound(Darr), 1 To 8)
With Sheets(2)
[COLOR=#0000ff]Nban = .Range("[/COLOR][COLOR=#ff0000]A1[/COLOR][COLOR=#0000ff]")[/COLOR]
For i = 1 To UBound(Darr) - 1
    If Darr(i + 1, 1) = "" Then Darr(i + 1, 1) = Darr(i, 1)
    If Darr(i, 9) = Nban Then
        k = k + 1
        For j = 2 To 8
            Arr(k, j) = Darr(i, j)
        Next j
        If tmp <> Darr(i, 1) Then
            Arr(k, 1) = Darr(i, 1)
            tmp = Darr(i, 1)
        End If
    End If
Next i
.Range("A2:H20000").[COLOR=#ff0000]ClearContents[/COLOR]
.Range("A2").Resize(k, 8) = Arr
End With
End Sub
ClearContents chỉ xóa dũ liệu không xóa định dạng
Nban = .Range("A1") nếu cần thì thay địa chỉ A1 bằng địa chỉ khác
 
@HieuCd: Bác giúp em thêm tý nữa được không ạ. Khi in ra sản phẩm bác loại trừ những sản phẩm có Xuất sứ là XS1 hoặc XS9 ở cột Xuất sứ ( Mà em đã đánh dấu đỏ như ở File đính kèm ) được không ạ.
 

File đính kèm

@HieuCd: Bác giúp em thêm tý nữa được không ạ. Khi in ra sản phẩm bác loại trừ những sản phẩm có Xuất sứ là XS1 hoặc XS9 ở cột Xuất sứ ( Mà em đã đánh dấu đỏ như ở File đính kèm ) được không ạ.
file bạn gởi bị lổi
bạn sửa code lại
Mã:
Sub GPE()
Dim Darr, Arr(), Nban As String, i As Long, j As Integer, k As Integer, tmp As String
With Sheets(1)
    Darr = .Range("A2:I" & .Range("B2").End(xlDown).Row + 1)
End With
ReDim Arr(1 To UBound(Darr), 1 To 8)
With Sheets(2)
Nban = .Range("A1")
For i = 1 To UBound(Darr) - 1
    If Darr(i + 1, 1) = "" Then Darr(i + 1, 1) = Darr(i, 1)
[COLOR=#ff0000]    If Darr(i, 9) = Nban And Darr(i, 7) <> "XS1" And Darr(i, 7) <> "XS9" Then[/COLOR]
        k = k + 1
        For j = 2 To 8
            Arr(k, j) = Darr(i, j)
        Next j
        If tmp <> Darr(i, 1) Then
            Arr(k, 1) = Darr(i, 1)
            tmp = Darr(i, 1)
        End If
    End If
Next i
.Range("A2:H20000").ClearContents
.Range("A2").Resize(k, 8) = Arr
End With
End Sub
 
@HieuCD: Cảm ơn bác ạ :D. Bác giúp em nốt trường hợp này với ạ. Chả là khi Sản phẩm ở cột Xuất sứ chỉ có XS1 & XS9 thì khi em chạy Macro nó báo lỗi như ảnh vs file em đính kèm. Bác thay cái báo lỗi này thành 1 cái thông báo là " Không có dữ liệu " giùm em với được không ạ.
 

File đính kèm

@HieuCD: Cảm ơn bác ạ :D. Bác giúp em nốt trường hợp này với ạ. Chả là khi Sản phẩm ở cột Xuất sứ chỉ có XS1 & XS9 thì khi em chạy Macro nó báo lỗi như ảnh vs file em đính kèm. Bác thay cái báo lỗi này thành 1 cái thông báo là " Không có dữ liệu " giùm em với được không ạ.
Bạn thay code nầy
Mã:
Sub GPE()
Dim Darr, Arr(), Nban As String, i As Long, j As Integer, k As Integer, tmp As String
With Sheets(1)
    Darr = .Range("A2:I" & .Range("B65500").End(xlUp).Row + 1)
End With
ReDim Arr(1 To UBound(Darr), 1 To 8)
With Sheets(2)
Nban = .Range("A1")
For i = 1 To UBound(Darr) - 1
    If Darr(i + 1, 1) = "" Then Darr(i + 1, 1) = Darr(i, 1)
    If Darr(i, 9) = Nban And Darr(i, 7) <> "XS1" And Darr(i, 7) <> "XS9" Then
        k = k + 1
        For j = 2 To 8
            Arr(k, j) = Darr(i, j)
        Next j
        If tmp <> Darr(i, 1) Then
            Arr(k, 1) = Darr(i, 1)
            tmp = Darr(i, 1)
        End If
    End If
Next i
If k = 0 Then
    MsgBox "Khong co du lieu nguoi ban " & Nban & " co xuat su XS1 va XS9"
    Exit Sub
End If
.Range("A2:H20000").ClearContents
.Range("A2").Resize(k, 8) = Arr
End With
End Sub
 
@Hieucd: Cho em lầy bác thêm chút nữa với ạ. Chả là dữ liệu chỗ XS1 của em là chữ "Được đấy" nhưng do VBA ko hỗ trợ tiếng việt và em mày mò cả tối thì em được biết phải viết bằng mã ChrW gì đó. Em loay hoay cả tối ko được. Bác cho em xin cái mã này với được ko ạ -=.,,-=.,,
 
Mã:
[TABLE="width: 72"]
[TR]
[TD="colspan: 2"]mã acci[/TD]
[/TR]
[TR]
[TD]á[/TD]
[TD="align: right"]225[/TD]
[/TR]
[TR]
[TD]à[/TD]
[TD="align: right"]224[/TD]
[/TR]
[TR]
[TD]ả[/TD]
[TD="align: right"]7843[/TD]
[/TR]
[TR]
[TD]ã[/TD]
[TD="align: right"]227[/TD]
[/TR]
[TR]
[TD]ạ[/TD]
[TD="align: right"]7841[/TD]
[/TR]
[TR]
[TD]ắ[/TD]
[TD="align: right"]7855[/TD]
[/TR]
[TR]
[TD]ằ[/TD]
[TD="align: right"]7857[/TD]
[/TR]
[TR]
[TD]ẳ[/TD]
[TD="align: right"]7859[/TD]
[/TR]
[TR]
[TD]ẵ[/TD]
[TD="align: right"]7861[/TD]
[/TR]
[TR]
[TD]ặ[/TD]
[TD="align: right"]7863[/TD]
[/TR]
[TR]
[TD]ấ[/TD]
[TD="align: right"]7845[/TD]
[/TR]
[TR]
[TD]ầ[/TD]
[TD="align: right"]7847[/TD]
[/TR]
[TR]
[TD]ẩ[/TD]
[TD="align: right"]7849[/TD]
[/TR]
[TR]
[TD]ẫ[/TD]
[TD="align: right"]7851[/TD]
[/TR]
[TR]
[TD]ậ[/TD]
[TD="align: right"]7853[/TD]
[/TR]
[TR]
[TD]ó[/TD]
[TD="align: right"]243[/TD]
[/TR]
[TR]
[TD]ò[/TD]
[TD="align: right"]242[/TD]
[/TR]
[TR]
[TD]ỏ[/TD]
[TD="align: right"]7887[/TD]
[/TR]
[TR]
[TD]õ[/TD]
[TD="align: right"]245[/TD]
[/TR]
[TR]
[TD]ọ[/TD]
[TD="align: right"]7885[/TD]
[/TR]
[TR]
[TD]ố[/TD]
[TD="align: right"]7889[/TD]
[/TR]
[TR]
[TD]ồ[/TD]
[TD="align: right"]7891[/TD]
[/TR]
[TR]
[TD]ổ[/TD]
[TD="align: right"]7893[/TD]
[/TR]
[TR]
[TD]ỗ[/TD]
[TD="align: right"]7895[/TD]
[/TR]
[TR]
[TD]ộ[/TD]
[TD="align: right"]7897[/TD]
[/TR]
[TR]
[TD]ớ[/TD]
[TD="align: right"]7899[/TD]
[/TR]
[TR]
[TD]ờ[/TD]
[TD="align: right"]7901[/TD]
[/TR]
[TR]
[TD]ở[/TD]
[TD="align: right"]7903[/TD]
[/TR]
[TR]
[TD]ỡ[/TD]
[TD="align: right"]7905[/TD]
[/TR]
[TR]
[TD]ợ[/TD]
[TD="align: right"]7907[/TD]
[/TR]
[TR]
[TD]ú[/TD]
[TD="align: right"]250[/TD]
[/TR]
[TR]
[TD]ù[/TD]
[TD="align: right"]249[/TD]
[/TR]
[TR]
[TD]ủ[/TD]
[TD="align: right"]7911[/TD]
[/TR]
[TR]
[TD]ũ[/TD]
[TD="align: right"]361[/TD]
[/TR]
[TR]
[TD]ụ[/TD]
[TD="align: right"]7909[/TD]
[/TR]
[TR]
[TD]ứ[/TD]
[TD="align: right"]7913[/TD]
[/TR]
[TR]
[TD]ừ[/TD]
[TD="align: right"]7915[/TD]
[/TR]
[TR]
[TD]ử[/TD]
[TD="align: right"]7917[/TD]
[/TR]
[TR]
[TD]ữ[/TD]
[TD="align: right"]7919[/TD]
[/TR]
[TR]
[TD]ự[/TD]
[TD="align: right"]7921[/TD]
[/TR]
[TR]
[TD]é[/TD]
[TD="align: right"]233[/TD]
[/TR]
[TR]
[TD]è[/TD]
[TD="align: right"]232[/TD]
[/TR]
[TR]
[TD]ẻ[/TD]
[TD="align: right"]7867[/TD]
[/TR]
[TR]
[TD]ẽ[/TD]
[TD="align: right"]7869[/TD]
[/TR]
[TR]
[TD]ẹ[/TD]
[TD="align: right"]7865[/TD]
[/TR]
[TR]
[TD]ế[/TD]
[TD="align: right"]7871[/TD]
[/TR]
[TR]
[TD]ề[/TD]
[TD="align: right"]7873[/TD]
[/TR]
[TR]
[TD]ể[/TD]
[TD="align: right"]7875[/TD]
[/TR]
[TR]
[TD]ễ[/TD]
[TD="align: right"]7877[/TD]
[/TR]
[TR]
[TD]ệ[/TD]
[TD="align: right"]7879[/TD]
[/TR]
[TR]
[TD]ý[/TD]
[TD="align: right"]253[/TD]
[/TR]
[TR]
[TD]ỳ[/TD]
[TD="align: right"]7923[/TD]
[/TR]
[TR]
[TD]ỷ[/TD]
[TD="align: right"]7927[/TD]
[/TR]
[TR]
[TD]ỹ[/TD]
[TD="align: right"]7929[/TD]
[/TR]
[TR]
[TD]ỵ[/TD]
[TD="align: right"]7925[/TD]
[/TR]
[TR]
[TD]Á[/TD]
[TD="align: right"]193[/TD]
[/TR]
[TR]
[TD]À[/TD]
[TD="align: right"]192[/TD]
[/TR]
[TR]
[TD]Ả[/TD]
[TD="align: right"]7842[/TD]
[/TR]
[TR]
[TD]Ã[/TD]
[TD="align: right"]195[/TD]
[/TR]
[TR]
[TD]Ạ[/TD]
[TD="align: right"]7840[/TD]
[/TR]
[TR]
[TD]Ắ[/TD]
[TD="align: right"]7854[/TD]
[/TR]
[TR]
[TD]Ằ[/TD]
[TD="align: right"]7856[/TD]
[/TR]
[TR]
[TD]Ẳ[/TD]
[TD="align: right"]7858[/TD]
[/TR]
[TR]
[TD]Ẵ[/TD]
[TD="align: right"]7860[/TD]
[/TR]
[TR]
[TD]Ặ[/TD]
[TD="align: right"]7862[/TD]
[/TR]
[TR]
[TD]Ấ[/TD]
[TD="align: right"]7844[/TD]
[/TR]
[TR]
[TD]Ầ[/TD]
[TD="align: right"]7846[/TD]
[/TR]
[TR]
[TD]Ẩ[/TD]
[TD="align: right"]7848[/TD]
[/TR]
[TR]
[TD]Ẫ[/TD]
[TD="align: right"]7850[/TD]
[/TR]
[TR]
[TD]Ậ[/TD]
[TD="align: right"]7852[/TD]
[/TR]
[TR]
[TD]É[/TD]
[TD="align: right"]201[/TD]
[/TR]
[TR]
[TD]È[/TD]
[TD="align: right"]200[/TD]
[/TR]
[TR]
[TD]Ẻ[/TD]
[TD="align: right"]7866[/TD]
[/TR]
[TR]
[TD]Ẽ[/TD]
[TD="align: right"]7868[/TD]
[/TR]
[TR]
[TD]Ẹ[/TD]
[TD="align: right"]7864[/TD]
[/TR]
[TR]
[TD]Ế[/TD]
[TD="align: right"]7870[/TD]
[/TR]
[TR]
[TD]Ề[/TD]
[TD="align: right"]7872[/TD]
[/TR]
[TR]
[TD]Ể[/TD]
[TD="align: right"]7874[/TD]
[/TR]
[TR]
[TD]Ễ[/TD]
[TD="align: right"]7876[/TD]
[/TR]
[TR]
[TD]Ệ[/TD]
[TD="align: right"]7878[/TD]
[/TR]
[TR]
[TD]Ó[/TD]
[TD="align: right"]211[/TD]
[/TR]
[TR]
[TD]Ò[/TD]
[TD="align: right"]210[/TD]
[/TR]
[TR]
[TD]Ỏ[/TD]
[TD="align: right"]7886[/TD]
[/TR]
[TR]
[TD]Õ[/TD]
[TD="align: right"]213[/TD]
[/TR]
[TR]
[TD]Ọ[/TD]
[TD="align: right"]7884[/TD]
[/TR]
[TR]
[TD]Ố[/TD]
[TD="align: right"]7888[/TD]
[/TR]
[TR]
[TD]Ồ[/TD]
[TD="align: right"]7890[/TD]
[/TR]
[TR]
[TD]Ổ[/TD]
[TD="align: right"]7892[/TD]
[/TR]
[TR]
[TD]Ỗ[/TD]
[TD="align: right"]7894[/TD]
[/TR]
[TR]
[TD]Ộ[/TD]
[TD="align: right"]7896[/TD]
[/TR]
[TR]
[TD]Ớ[/TD]
[TD="align: right"]7898[/TD]
[/TR]
[TR]
[TD]Ờ[/TD]
[TD="align: right"]7900[/TD]
[/TR]
[TR]
[TD]Ở[/TD]
[TD="align: right"]7902[/TD]
[/TR]
[TR]
[TD]Ỡ[/TD]
[TD="align: right"]7904[/TD]
[/TR]
[TR]
[TD]Ợ[/TD]
[TD="align: right"]7906[/TD]
[/TR]
[TR]
[TD]Ú[/TD]
[TD="align: right"]218[/TD]
[/TR]
[TR]
[TD]Ù[/TD]
[TD="align: right"]217[/TD]
[/TR]
[TR]
[TD]Ủ[/TD]
[TD="align: right"]7910[/TD]
[/TR]
[TR]
[TD]Ũ[/TD]
[TD="align: right"]360[/TD]
[/TR]
[TR]
[TD]Ụ[/TD]
[TD="align: right"]7908[/TD]
[/TR]
[TR]
[TD]Ứ[/TD]
[TD="align: right"]7912[/TD]
[/TR]
[TR]
[TD]Ừ[/TD]
[TD="align: right"]7914[/TD]
[/TR]
[TR]
[TD]Ử[/TD]
[TD="align: right"]7916[/TD]
[/TR]
[TR]
[TD]Ữ[/TD]
[TD="align: right"]7918[/TD]
[/TR]
[TR]
[TD]Ự[/TD]
[TD="align: right"]7920[/TD]
[/TR]
[TR]
[TD]Ý[/TD]
[TD="align: right"]221[/TD]
[/TR]
[TR]
[TD]Ỳ[/TD]
[TD="align: right"]7922[/TD]
[/TR]
[TR]
[TD]Ỷ[/TD]
[TD="align: right"]7926[/TD]
[/TR]
[TR]
[TD]Ỹ[/TD]
[TD="align: right"]7928[/TD]
[/TR]
[TR]
[TD]Ỵ[/TD]
[TD="align: right"]7924[/TD]
[/TR]
[TR]
[TD]đ[/TD]
[TD="align: right"]273[/TD]
[/TR]
[TR]
[TD]Ð[/TD]
[TD="align: right"]208[/TD]
[/TR]
[TR]
[TD]ă[/TD]
[TD="align: right"]259[/TD]
[/TR]
[TR]
[TD]Ă[/TD]
[TD="align: right"]258[/TD]
[/TR]
[TR]
[TD]â[/TD]
[TD="align: right"]226[/TD]
[/TR]
[TR]
[TD]Â[/TD]
[TD="align: right"]194[/TD]
[/TR]
[TR]
[TD]ê[/TD]
[TD="align: right"]234[/TD]
[/TR]
[TR]
[TD]Ê[/TD]
[TD="align: right"]202[/TD]
[/TR]
[TR]
[TD]ơ[/TD]
[TD="align: right"]417[/TD]
[/TR]
[TR]
[TD]Ơ[/TD]
[TD="align: right"]416[/TD]
[/TR]
[TR]
[TD]ô[/TD]
[TD="align: right"]244[/TD]
[/TR]
[TR]
[TD]Ô[/TD]
[TD="align: right"]212[/TD]
[/TR]
[TR]
[TD]ư[/TD]
[TD="align: right"]432[/TD]
[/TR]
[TR]
[TD]Ư[/TD]
[TD="align: right"]431[/TD]
[/TR]
[TR]
[TD]Í[/TD]
[TD="align: right"]205[/TD]
[/TR]
[TR]
[TD]Ì[/TD]
[TD="align: right"]204[/TD]
[/TR]
[TR]
[TD]Ỉ[/TD]
[TD="align: right"]7880[/TD]
[/TR]
[TR]
[TD]Ĩ[/TD]
[TD="align: right"]296[/TD]
[/TR]
[TR]
[TD]Ị[/TD]
[TD="align: right"]7882[/TD]
[/TR]
[TR]
[TD]í[/TD]
[TD="align: right"]237[/TD]
[/TR]
[TR]
[TD]ì[/TD]
[TD="align: right"]236[/TD]
[/TR]
[TR]
[TD]ỉ[/TD]
[TD="align: right"]7881[/TD]
[/TR]
[TR]
[TD]ĩ[/TD]
[TD="align: right"]297[/TD]
[/TR]
[TR]
[TD]ị[/TD]
[TD="align: right"]7883
[/TD]
[/TR]
[/TABLE]
 
@HieuCD: Bác kiểm tra giúp em xem em viết thế này sai ở chỗ nào ạ. Em làm mãi không được:
>< ChrW(208) & ChrW(432) & ChrW(7907) & "c" ChrW(273)&Chrw(7845)&"y"
 
Bạn HieuCD,

Một số mã mình dùng thử thì thấy không dùng được:

Ví dụ: gõ lệnh Chrw(7843) nó không ra kí tự ả mà ra dấu ?
 
thấy các bạn hỏ bảng mã code unicode, mình gửi các bạn file bảng mã cho dễ theo dõi, cái này có trên GPE, nhưng chắc các bạn không để ý hoặc tìm thấy.
Vấn đề của bạn @khuongvietphong thì mình nghĩ bạn đang test trên debug nên nó ra dấu ? (1 số kí tự debug ko hỗ trợ hiển thị hết đc) bạn test trên cell nhé.
 

File đính kèm

@Quangluu1989 Bác cho hỏi là em viết chữ "Được đấy" trong hàm VBA thì Dấu cách giữa chữ "Được" và "chữ đấy" viết như thế nào ạ
 
@HieuCD: Em tiếp tục có thêm vấn đề với bảng này. Nếu được xin nhờ bác giúp em với ạ. Em đính file đính kèm là 2 file khác nhau, mỗi file gồm 2 sheet trong đó Sheet1 là em nhập các sản phẩm theo Danh mục khác nhau, còn ở Sheet 2 em muốn tổng hợp tất cả sản phẩm theo Danh mục đã được nhập vào ở Sheet1 của cả 2 file ạ. Mong bác tiếp tục giúp em với ạ. Em xin cảm ơn

Bạn thay code nầy
Mã:
Sub GPE()
Dim Darr, Arr(), Nban As String, i As Long, j As Integer, k As Integer, tmp As String
With Sheets(1)
    Darr = .Range("A2:I" & .Range("B65500").End(xlUp).Row + 1)
End With
ReDim Arr(1 To UBound(Darr), 1 To 8)
With Sheets(2)
Nban = .Range("A1")
For i = 1 To UBound(Darr) - 1
    If Darr(i + 1, 1) = "" Then Darr(i + 1, 1) = Darr(i, 1)
    If Darr(i, 9) = Nban And Darr(i, 7) <> "XS1" And Darr(i, 7) <> "XS9" Then
        k = k + 1
        For j = 2 To 8
            Arr(k, j) = Darr(i, j)
        Next j
        If tmp <> Darr(i, 1) Then
            Arr(k, 1) = Darr(i, 1)
            tmp = Darr(i, 1)
        End If
    End If
Next i
If k = 0 Then
    MsgBox "Khong co du lieu nguoi ban " & Nban & " co xuat su XS1 va XS9"
    Exit Sub
End If
.Range("A2:H20000").ClearContents
.Range("A2").Resize(k, 8) = Arr
End With
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
* Em quên mất, thiếu 1 điều kiện sắp xếp khi tổng hợp ạ:
Ở cột Tình trạng có nhiều loại Tình trạng nhưng có 3 cái tình trạng đặc biệt ví dụ là TT1, TT2, và TT3 thì những Sản phẩm có Tình trạng là 1 trong 3 Tình trạng này phải được xếp trên những Sản phẩm khác trong Danh mục ạ. +-+-+-++-+-+-++-+-+-+
 
Code này bác sửa cho em thêm chút nữa được ko ạ. Ở sheet 2 em muốn in ra cả cái phần comment (chú thích ) nếu có được đính kèm ở ô sản phẩm nằm ở Sheet 1 được không ạ. Ỏ Topic kia http://www.giaiphapexcel.com/forum/...m-chiếu-qua-1-cột-bằng-VBA-theo-dạng-Danh-mục Source bác cho em lúc em chạy em thấy bác có làm cái này và in ra cả định dạng style của Dữ liệu gốc nữa %#^#$ . Bác giúp em nốt với ạ. Mấy ngày nay em loay hoay cái này mãi may có bác giúp @$@!^%
sửa code
Mã:
Sub GPE()
Dim Darr, Arr(), Nban As String, i As Long, j As Integer, k As Integer, tmp As String
With Sheets(1)
    Darr = .Range("A2:I" & .Range("B2").End(xlDown).Row + 1)
End With
ReDim Arr(1 To UBound(Darr), 1 To 8)
With Sheets(2)
[COLOR=#0000ff]Nban = .Range("[/COLOR][COLOR=#ff0000]A1[/COLOR][COLOR=#0000ff]")[/COLOR]
For i = 1 To UBound(Darr) - 1
    If Darr(i + 1, 1) = "" Then Darr(i + 1, 1) = Darr(i, 1)
    If Darr(i, 9) = Nban Then
        k = k + 1
        For j = 2 To 8
            Arr(k, j) = Darr(i, j)
        Next j
        If tmp <> Darr(i, 1) Then
            Arr(k, 1) = Darr(i, 1)
            tmp = Darr(i, 1)
        End If
    End If
Next i
.Range("A2:H20000").[COLOR=#ff0000]ClearContents[/COLOR]
.Range("A2").Resize(k, 8) = Arr
End With
End Sub
ClearContents chỉ xóa dũ liệu không xóa định dạng
Nban = .Range("A1") nếu cần thì thay địa chỉ A1 bằng địa chỉ khác
 
Lần chỉnh sửa cuối:
P/s: Ý em là giữ nguyên định dạng style và chú thích đích kèm ở ô như file em đính kèm đấy ạ ( chính là file của công ty em làm việc em chỉ đổi dữ liệu cho dễ nhìn thôi ạ ). Cảm ơn bác và mọi người rất nhiều.
 

File đính kèm

Lần chỉnh sửa cuối:
P/s: Ý em là giữ nguyên định dạng style và chú thích đích kèm ở ô như file em đính kèm đấy ạ ( chính là file của công ty em làm việc em chỉ đổi dữ liệu cho dễ nhìn thôi ạ ). Cảm ơn bác và mọi người rất nhiều.
bạn dùng code nầy
Mã:
Sub GPE()
Dim Nban As String, tmp As String, i As Long
Application.ScreenUpdating = False
With Sheets(2)
Nban = .Range("A1")
.Range("A2:H20000").ClearContents
End With
With Sheets(1)
    .Range("A2:I" & .Range("B65000").End(xlUp).Row).Copy Sheets(2).Range("A2")
End With
Sheets(2).Select
For i = 2 To Range("B65500").End(xlUp).Row
    If Cells(i, 1) = "" Then Cells(i, 1) = Cells(i - 1, 1)
Next
Range("$A$1:$I$16").AutoFilter Field:=9, Criteria1:="<>" & Nban
Rows("2:" & Range("B65500").End(xlUp).Row).Delete Shift:=xlUp
Selection.AutoFilter
For i = 2 To Range("B65500").End(xlUp).Row
    Cells(i, 9) = ""
    If Cells(i, 1) = tmp Then
        Cells(i, 1) = ""
    Else
        tmp = Cells(i, 1)
    End If
Next
Application.ScreenUpdating = True
End Sub
 
@HieuCD: Cảm ơn bác nhiều lắm ạ. Cảm ơn bác đã giúp đỡ rất nhiệt tình với em :bye1::bye1::bye1::bye1:
bạn dùng code nầy
Mã:
Sub GPE()
Dim Nban As String, tmp As String, i As Long
Application.ScreenUpdating = False
With Sheets(2)
Nban = .Range("A1")
.Range("A2:H20000").ClearContents
End With
With Sheets(1)
    .Range("A2:I" & .Range("B65000").End(xlUp).Row).Copy Sheets(2).Range("A2")
End With
Sheets(2).Select
For i = 2 To Range("B65500").End(xlUp).Row
    If Cells(i, 1) = "" Then Cells(i, 1) = Cells(i - 1, 1)
Next
Range("$A$1:$I$16").AutoFilter Field:=9, Criteria1:="<>" & Nban
Rows("2:" & Range("B65500").End(xlUp).Row).Delete Shift:=xlUp
Selection.AutoFilter
For i = 2 To Range("B65500").End(xlUp).Row
    Cells(i, 9) = ""
    If Cells(i, 1) = tmp Then
        Cells(i, 1) = ""
    Else
        tmp = Cells(i, 1)
    End If
Next
Application.ScreenUpdating = True
End Sub
 
@HieuCD: Bác xem lại giúp em 2 vấn đề ở dưới với ạ : +-+-+-++-+-+-++-+-+-+
 
Lần chỉnh sửa cuối:
@HieuCD:
- Ở Sheet người bán khi em nhập dữ liệu từ cột I trở đi thì khi run code những dữ liệu này bị xóa dần sau mỗi lần chạy code. Bác xem có thể fix cái này giúp e được ko ạ. Em có đính kèm file đã add sẵn VBA của bác bác chạy thử là thấy ạ.

- File em đính kèm gồm 2 Sub bác cho nhưng khi em tạo Sub chạy lần lượt từng sub một như bác hướng dẫn ở topic kia
(Nếu đã có sub A1(), sub A2(), sub A3()
code chạy lần lượt 3 sub trên
Sub GPE()
...
Call A1
Call A2
Call A3
...
End Sub ) thì không được. Bác xem lại giùm em với nhé.

Cảm ơn bác nhiều ạ

bạn dùng code nầy
Mã:
Sub GPE()
Dim Nban As String, tmp As String, i As Long
Application.ScreenUpdating = False
With Sheets(2)
Nban = .Range("A1")
.Range("A2:H20000").ClearContents
End With
With Sheets(1)
    .Range("A2:I" & .Range("B65000").End(xlUp).Row).Copy Sheets(2).Range("A2")
End With
Sheets(2).Select
For i = 2 To Range("B65500").End(xlUp).Row
    If Cells(i, 1) = "" Then Cells(i, 1) = Cells(i - 1, 1)
Next
Range("$A$1:$I$16").AutoFilter Field:=9, Criteria1:="<>" & Nban
Rows("2:" & Range("B65500").End(xlUp).Row).Delete Shift:=xlUp
Selection.AutoFilter
For i = 2 To Range("B65500").End(xlUp).Row
    Cells(i, 9) = ""
    If Cells(i, 1) = tmp Then
        Cells(i, 1) = ""
    Else
        tmp = Cells(i, 1)
    End If
Next
Application.ScreenUpdating = True
End Sub
 

File đính kèm

Ai biết fix giùm e với ạ +-+-+-++-+-+-++-+-+-+
 
bạn phải đặt code vào chung module
đã chỉnh code theo ý bạn
 

File đính kèm

@HieuCD: Sub Nguoiban1 vẫn bị anh ạ. Mỗi lần em chạy Sub này thì các ô có "x" em nhập bằng tay vào từ cột I sang phải trở đi bị xóa hết . Em chỉ muốn in vào từ cột A đến cột H ở Sheet 3 thôi anh ạ còn dữ liệu em nhập vào từ cột I trớ đi ko bị ảnh hưởng. Em đính kèm file nhờ anh xem lại ạ

bạn phải đặt code vào chung module
đã chỉnh code theo ý bạn
 

File đính kèm

Lần chỉnh sửa cuối:
nó bị xóa do không phải NB A, bạn cập nhập dữ liệu thì thứ tự dòng thay đổi thì các cột có X... có thể không đúng dòng của Sp
 
Có fix được ko anh vì em thấy code ở dưới anh cho em lần trước không bị mà ( Code này anh cho em trước khi em muốn sửa là giữ nguyên định dạng & kèm chú thích của ô )

Sub GPE()
Dim Darr, Arr(), Nban As String, i As Long, j As Integer, k As Integer, tmp As String
With Sheets(1)
Darr = .Range("A2:I" & .Range("B2").End(xlDown).Row + 1)
End With
ReDim Arr(1 To UBound(Darr), 1 To 8)
With Sheets(2)
Nban = .Range("A1")
For i = 1 To UBound(Darr) - 1
If Darr(i + 1, 1) = "" Then Darr(i + 1, 1) = Darr(i, 1)
If Darr(i, 9) = Nban Then
k = k + 1
For j = 2 To 8
Arr(k, j) = Darr(i, j)
Next j
If tmp <> Darr(i, 1) Then
Arr(k, 1) = Darr(i, 1)
tmp = Darr(i, 1)
End If
End If
Next i
.Range("A2:H20000").ClearContents
.Range("A2").Resize(k, 8) = Arr
End With End Sub

nó bị xóa do không phải NB A, bạn cập nhập dữ liệu thì thứ tự dòng thay đổi thì các cột có X... có thể không đúng dòng của Sp
 
@HieuCD: Các cột có "x" là những phần em nhập vào không liên quan gì đến vùng từ cột A đến cột H và nó cũng không liên quan gì đến người bán A hay sản phẩm và vì thế ko cần động vào nó, giữ nguyên nó được ko anh. Code trước ở trên anh cho em ko bị mà
 
Lần chỉnh sửa cuối:
@HieuCD: Vâng em đang xem anh ạ
 
@HieuCD:
Anh ơi ở Sheet Người bán Em ko muốn in ra Cột I là Người bán A vì Cả sheet này là dành cho Người bán A rồi và Cột I là những text em điền vào mà ko muốn bị mất khi chạy Sub thì em sửa chỗ nào vậy anh ?
bạn test file xem đúng ý chưa
 

File đính kèm

  • 2016-09-11_210017.jpg
    2016-09-11_210017.jpg
    29.6 KB · Đọc: 14
sửa đoạn màu đỏ
Mã:
With Sheets(3)
Nban = .Range("A1")
.Range([COLOR=#ff0000]"A2:H20000"[/COLOR][COLOR=#ff0000][/COLOR]).ClearContents
End With
...
Next
    .Range([COLOR=#ff0000]"A2:H"[/COLOR] & .Range("B65000").End(xlUp).Row).Copy Sheets(3).Range("A2")
End With
 
@HieuCD: Được rồi anh ạ. Cảm ơn anh rất nhiều. Anh có thể inbox em số điện thoại của anh hay bất cứ số điện thoại của ai mà anh quý mến được ko ạ. Em muốn gửi tặng 1 cái thẻ card vào đó. Dẫu biết anh giúp em tận tình ko tính toán gì nhưng em vẫn muốn cảm ơn anh ạ. Anh có thể nhắn ib em số đt bất kỳ nào mà anh muốn nạp ko ạ. Em cảm ơn anh rất nhiều.
sửa đoạn màu đỏ
Mã:
With Sheets(3)
Nban = .Range("A1")
.Range([COLOR=#ff0000]"A2:H20000"[/COLOR]).ClearContents
End With
...
Next
    .Range([COLOR=#ff0000]"A2:H"[/COLOR] & .Range("B65000").End(xlUp).Row).Copy Sheets(3).Range("A2")
End With
 
@HieuCD: Được rồi anh ạ. Cảm ơn anh rất nhiều. Anh có thể inbox em số điện thoại của anh hay bất cứ số điện thoại của ai mà anh quý mến được ko ạ. Em muốn gửi tặng 1 cái thẻ card vào đó. Dẫu biết anh giúp em tận tình ko tính toán gì nhưng em vẫn muốn cảm ơn anh ạ. Anh có thể nhắn ib em số đt bất kỳ nào mà anh muốn nạp ko ạ. Em cảm ơn anh rất nhiều.
Được giúp bạn là mình vui rồi, chúc bạn luôn thành công trong công việc
 
Dạ vâng. Có những mem như anh tụi gà như em mới có nơi bấu víu. Nhìu lúc hỏi nhiều quá cũng ngại anh ạ nhưng dốt lập trình nên ko biết làm sao. Cảm ơn anh rất nhiều ạ.
P/s: Em có chút vướng mắc ở đây http://www.giaiphapexcel.com/forum/...ệu-cùng-chú-thích-gắn-kèm&p=742540#post742540 Nếu có thể mong anh giúp em ạ +-+-+-+ Hix...

Được giúp bạn là mình vui rồi, chúc bạn luôn thành công trong công việc
 
@HieuCD: Có cái lỗi này kỳ quặc anh ạ. Lỗi này là do Sub Nguoiban. Mỗi khi em vô tình click chuột vào 1 ô trống ( ô trống anh nhé) ở Sheet Tổng hợp thì run Sub Nguoiban y rằng báo lỗi. Lỗi này thật phiền toái anh ạ. Ko lẽ ở Sheet Tổng hợp mình ko được chạm vào cái gì sao... mà thực tế ở Sheet này công ty em còn nhập liệu thêm vào ở các cột khác nữa. Anh xem có cách nào fix giúp em ko ạ. Em vừa phải gỡ Sub ra khỏi file công ty vì lỗi này **~****~****~**
bạn test file xem đúng ý chưa
 
Anh xem lại giúp em với ạ :
Có cái lỗi này kỳ quặc anh ạ. Lỗi này là do Sub Nguoiban. Mỗi khi em vô tình click chuột vào 1 ô trống ( ô trống anh nhé) ở Sheet Tổng hợp thì run Sub Nguoiban y rằng báo lỗi. Lỗi này thật phiền toái anh ạ. Ko lẽ ở Sheet Tổng hợp mình ko được chạm vào cái gì sao... mà thực tế ở Sheet này công ty em còn nhập liệu thêm vào ở các cột khác nữa. Anh xem có cách nào fix giúp em ko ạ.

bạn test file xem đúng ý chưa
 
Anh xem lại giúp em với ạ :
Có cái lỗi này kỳ quặc anh ạ. Lỗi này là do Sub Nguoiban. Mỗi khi em vô tình click chuột vào 1 ô trống ( ô trống anh nhé) ở Sheet Tổng hợp thì run Sub Nguoiban y rằng báo lỗi. Lỗi này thật phiền toái anh ạ. Ko lẽ ở Sheet Tổng hợp mình ko được chạm vào cái gì sao... mà thực tế ở Sheet này công ty em còn nhập liệu thêm vào ở các cột khác nữa. Anh xem có cách nào fix giúp em ko ạ.

do mình test không kỹ, nên chủ quan bớt một dòng lệnh cho gọn.Bạn thêm dòng lệnh màu đỏ
Mã:
Public Sub Nguoiban1()
Dim Nban As String, tmp As String, i As Long, Arr, Darr
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Sheets(3)
Nban = .Range("A1")
.Range("A2:H20000").ClearContents
End With
Sheets(2).Copy After:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
For i = 2 To .Range("B65500").End(xlUp).Row
    If .Cells(i, 1) = "" Then .Cells(i, 1) = .Cells(i - 1, 1)
Next
.Range("A1:I" & .Range("B65500").End(xlUp).Row).Sort Key1:=.Range("A1"), Order1:=xlAscending, _
        Key2:=.Range("B1"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1
[COLOR=#ff0000].Range("A1:I" & .Range("B65500").End(xlUp).Row).Select[/COLOR]
Selection.AutoFilter
.Range("$A$1:$I" & .Range("B65500").End(xlUp).Row).AutoFilter Field:=9, Criteria1:="<>" & Nban
.Rows("2:" & .Range("B65500").End(xlUp).Row).Delete Shift:=xlUp
Selection.AutoFilter
For i = 2 To .Range("B65500").End(xlUp).Row
    If .Cells(i, 1) = tmp Then
        .Cells(i, 1) = ""
    Else
        tmp = .Cells(i, 1)
    End If
Next
    .Range("A2:H" & .Range("B65000").End(xlUp).Row).Copy Sheets(3).Range("A2")
End With
Sheets(3).Select
ThisWorkbook.Sheets(Sheets.Count).Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Cảm ơn anh nhiều lắm. E test kỹ. Chạy ngon anh ạ. Cảm ơn anh nhiều nhé.
 

Bài viết mới nhất

Back
Top Bottom