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

khuongvietphong · 9/9/16

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 ?

quanluu · 9/9/16

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é.

khuongvietphong · 9/9/16

quanluu1989 đã viết:
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é.

Em Test thử được rồi. Hóa ra là vậy à. Cảm ơn anh nhá

ohho84 · 9/9/16

@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 ạ

quanluu · 9/9/16

ohho84 đã viết:
@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 ạ

thì bạn viết như bình thường thui ...& " " & .....

ohho84 · 9/9/16

@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

HieuCD đã viết:

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

ohho84 · 9/9/16

@HieuCD: Nếu bác giúp em bác trả lời vào Topic này giúp em với nhé http://www.giaiphapexcel.com/forum/...dữ-liệu-theo-Danh-mục-từ-các-file-khác-nhau-ạ

ohho84 · 9/9/16

* 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 ạ. +-+-+-+

ohho84 · 10/9/16

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 @$@!^%

HieuCD đã viết:

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

ohho84 · 10/9/16

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.

HieuCD · 10/9/16

ohho84 đã viết:
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

ohho84 · 10/9/16

@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:

HieuCD đã viết:

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

ohho84 · 11/9/16

@HieuCD: Bác xem lại giúp em 2 vấn đề ở dưới với ạ : +-+-+-+

ohho84 · 11/9/16

@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 ạ

HieuCD đã viết:

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

ohho84 · 11/9/16

Ai biết fix giùm e với ạ +-+-+-+

HieuCD · 11/9/16

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

ohho84 · 11/9/16

@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 ạ

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

HieuCD · 11/9/16

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

ohho84 · 11/9/16

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

HieuCD đã viết:
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

ohho84 · 11/9/16

@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à

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

Be all you can be !

Thành viên gắn bó

File đính kèm

Be all you can be !

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

Thành viên gắn bó

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

File đính kèm

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

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

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

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

File đính kèm

Chuyên gia GPE

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

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

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

File đính kèm

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

Chuyên gia GPE

File đính kèm

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

File đính kèm

Chuyên gia GPE

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

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

Đếm ngược thời gian