Thống kê dữ liệu từ 2 sheet với code VBA (1 người xem)

[qv7tb]

Chào GPE!
Với bài toán thống kê dữ liệu từ 2 sheet khác nhau quá nhiều, nhưng dạng bài của e có đôi chút khác biệt về thuật toán nên em qua diễn đàn nhờ các cao thủ viết giúp code thống kê dữ liệu với tốc độ xử lý code tối đa có thế.
Bài toán cụ thể như sau:
Sheet dữ liệu là dữ liệu có các phần tử có chứa các giá trị (A,B.. là các phần tử có thể là số hoặc chữ)
Sheet Thống kê là tổ hợp chập 2 các phần tử ở sheet dữ liệu. và gán các giá trị của phần tử theo nguyên tắc sau:
[TABLE="width: 440"]
[TR]
[TD]nếu A =1, B=1 or A=0, B=0 thì A U B=1
[/TD]
[/TR]
[TR]
[TD]
[/TD]
[/TR]
[TR]
[TD]nếu A =1, B=0 or A=0, B=1 thì A U B=0
[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]nếu A =0, B=" " or A=" ", B=0 thì A U B=0
[/TD]
[/TR]
[TR]
[TD]nếu A =1, B=" " or A=" ", B=1 thì A U B=0
[/TD]
[/TR]
[TR]
[TD]nếu A =" ", B=" " thì A U B=" "
[/TD]
[/TR]
[TR]
[TD](A phần tử A…G, B là phẩn tử có thể là số)

em có file ví dụ mọi người coi giúp.

Mọi người trên diễn đàn GPE quan tâm coi giúp code VBA nào cho hợp lý bài toán trên.
Em xin cảm ơn các bạn đã quan tâm và giúp đỡ!

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

 

[concogia]

Đứng ở sheet "TKe" hạy thử code này:

Public Sub LungTung()
    Dim DuLieu, Vung, Mg, I, J, K, kK, A
        Set DuLieu = Sheets("DLieu").[B4:P10]
        Set Vung = Sheets("DLieu").[A4:A10]
        ReDim Mg(1 To Application.WorksheetFunction.Combin(Vung.Rows.Count, 2), 1 To DuLieu.Columns.Count + 2)
            For I = 1 To Vung.Rows.Count - 1
                For J = I + 1 To Vung.Rows.Count
                    K = K + 1
                    Mg(K, 1) = Vung(I): Mg(K, 2) = Vung(J)
                        For kK = 1 To DuLieu.Columns.Count
                            A = DuLieu(I, kK) & DuLieu(J, kK)
                                If A = "" Then
                                    Mg(K, kK + 2) = ""
                                ElseIf A = "11" Or A = "00" Then
                                    Mg(K, kK + 2) = 1
                                Else
                                    Mg(K, kK + 2) = 0
                                End If
                        Next kK
                Next J
            Next I
    [A2].Resize(UBound(Mg), UBound(Mg, 2)) = Mg
End Sub

Thân

 

[nasalem]

ở excel 2007 tìm cái công cụ tool ở đâu vậy b?? làm sao cho chạy cái code này??

 

[qv7tb]

Thầy concogia xem loại được phần này sheet "DLiệu" có B410 và A4:A10 trong code mà vẫn lấy được các phần tử và giá trị gán trong phần tử không thầy?và nguyên tắc ấy có 1 phần thay đổi A=0,B=0 khi AUB=0 duy nhất trường hợp A=1,B=1 thì AUB=1.
Các cao thủ xem cho ý kiến và code hợp lý.
Xin chân thành cảm ơn!

 

[concogia]

Thầy concogia xem loại được phần này sheet "DLiệu" có B410 và A4:A10 trong code mà vẫn lấy được các phần tử và giá trị gán trong phần tử không thầy?và nguyên tắc ấy có 1 phần thay đổi A=0,B=0 khi AUB=0 duy nhất trường hợp A=1,B=1 thì AUB=1.
Các cao thủ xem cho ý kiến và code hợp lý.
Xin chân thành cảm ơn!

...và nguyên tắc ấy có 1 phần thay đổi A=0,B=0 khi AUB=0 duy nhất trường hợp A=1,B=1 thì AUB=1.

Cái này dễ "ẹct", bạn sửa trong code tí tẹo là được mà

...loại được phần này sheet "DLiệu" có B410 và A4:A10 trong code mà vẫn lấy được các phần tử và giá trị gán trong phần tử không

Cái này hông hiểu, dữ liệu nằm trong các vùng trên là đề bài, nếu không có thì lấy dữ liệu ở đâu để cho ra kết quả ???

 

[qv7tb]

Cái này dễ "ẹct", bạn sửa trong code tí tẹo là được mà

Cái này hông hiểu, dữ liệu nằm trong các vùng trên là đề bài, nếu không có thì lấy dữ liệu ở đâu để cho ra kết quả ???

Vâng cái này em biết. Nhưng ý em có code chạy vẫn lấy tổng quát vùng dữ liệu bỏ được dòng đó trên code không thầy?

 

[concogia]

Vâng cái này em biết. Nhưng ý em có code chạy vẫn lấy tổng quát vùng dữ liệu bỏ được dòng đó trên code không thầy?

Làm kiểu gì thì cũng phải khai báo vùng dữ liệu nguồn, không khai báo trong code thì cũng phải khai báo bằng Input Box khi chạy code thôi. (Hình như ý bạn là vậy)

 

[qv7tb]

Chào bác concogia!
Cũng lâu không vào diễn đàn post bài. Nhờ bác lọc giúp, cũng là bài toán như thế yêu cầu chỉ kết hợp các phần tử kết tiếp nhau thôi.
như file ví dụ sau.

 

[qv7tb]

Chào bác concogia!
Cũng lâu không vào diễn đàn post bài. Nhờ bác lọc giúp, cũng là bài toán như thế yêu cầu chỉ kết hợp các phần tử kết tiếp nhau thôi.
như file ví dụ sau.

Chắc thầy concogia đang bận, các bác cùng anh em diễn đàn cho em ý kiến đóng góp cho bài toán này chút.
Cảm ơn mọi quan tâm và giúp đỡ!

 

[qv7tb]

chào mọi người GPE !
Em có nhờ mọi người đưa ra lời giải giuý em cho bài toán sau lọc thêm điều kiện kế tiếp.Mọi người coi xem thế nào? Giải giuý em!
Cảm ơn mọi người quan tâm giuý đỡ!

 

[doveandrose]

Chào bác concogia!
Cũng lâu không vào diễn đàn post bài. Nhờ bác lọc giúp, cũng là bài toán như thế yêu cầu chỉ kết hợp các phần tử kết tiếp nhau thôi.
như file ví dụ sau.

#4 bạn nói

nguyên tắc ấy có 1 phần thay đổi A=0,B=0 khi AUB=0 duy nhất trường hợp A=1,B=1 thì AUB=1.

sao trong file bạn lại nói khác . vậy tôi biết làm theo cái nào ?

 

[qv7tb]

#4 bạn nói

sao trong file bạn lại nói khác . vậy tôi biết làm theo cái nào ?

bác cứ làm theo các trường hợp như bài 1 không sao.

 

[doveandrose]

Public Sub hello()
Dim arr As Variant, r As Long, rsArr As Variant, c As Long, tempStr As String, lc As Integer, lr As Long
lr = Sheet1.Range("A1000000").End(xlUp).Row
lc = Sheet1.UsedRange.SpecialCells(xlCellTypeLastCell).Column
arr = Sheet1.Range("A3:A" & lr).Resize(, lc).Value
ReDim rsArr(1 To UBound(arr) - 1, 1 To UBound(arr, 2) + 1)
For r = 2 To UBound(arr) - 1
    rsArr(r, 1) = arr(r, 1)
    rsArr(r, 2) = arr(r + 1, 1)
    For c = 2 To UBound(arr, 2) Step 1
        rsArr(1, c + 1) = arr(1, c)
        tempStr = WorksheetFunction.Trim(arr(r, c) & arr(r + 1, c))
        If tempStr = "00" Or tempStr = "11" Then
            rsArr(r, c + 1) = 1
        Else
            If Len(tempStr) > 0 Then rsArr(r, c + 1) = 0
        End If
    Next
Next
Sheet2.Range("A1").Resize(UBound(rsArr) + 20, UBound(rsArr, 2) + 20).ClearContents
Sheet2.Range("A1").Resize(UBound(rsArr), UBound(rsArr, 2)).Value = rsArr
End Sub

 

[qv7tb]

Public Sub hello()
Dim arr As Variant, r As Long, rsArr As Variant, c As Long, tempStr As String, lc As Integer, lr As Long
lr = Sheet1.Range("A1000000").End(xlUp).Row
lc = Sheet1.UsedRange.SpecialCells(xlCellTypeLastCell).Column
arr = Sheet1.Range("A3:A" & lr).Resize(, lc).Value
ReDim rsArr(1 To UBound(arr) - 1, 1 To UBound(arr, 2) + 1)
For r = 2 To UBound(arr) - 1
    rsArr(r, 1) = arr(r, 1)
    rsArr(r, 2) = arr(r + 1, 1)
    For c = 2 To UBound(arr, 2) Step 1
        rsArr(1, c + 1) = arr(1, c)
        tempStr = WorksheetFunction.Trim(arr(r, c) & arr(r + 1, c))
        If tempStr = "00" Or tempStr = "11" Then
            rsArr(r, c + 1) = 1
        Else
            If Len(tempStr) > 0 Then rsArr(r, c + 1) = 0
        End If
    Next
Next
Sheet2.Range("A1").Resize(UBound(rsArr) + 20, UBound(rsArr, 2) + 20).ClearContents
Sheet2.Range("A1").Resize(UBound(rsArr), UBound(rsArr, 2)).Value = rsArr
End Sub

Chào bác em chạy qua rồi, phát sinh lỗi bác ah?
khi A=1 B= "" thì AUB =1 không hiểu sao bác kiểm tra giúp em!
Cảm ơn bác quan tâm giúp đỡ!

 

[doveandrose]

Chào bác em chạy qua rồi, phát sinh lỗi bác ah?
khi A=1 B= "" thì AUB =1 không hiểu sao bác kiểm tra giúp em!
Cảm ơn bác quan tâm giúp đỡ!

file nào có lỗi đó bạn tô màu vùng có lỗi rồi up lên đây nhé

 

[qv7tb]

file nào có lỗi đó bạn tô màu vùng có lỗi rồi up lên đây nhé

em chưa kiểm tra hết, có vài điểm bác coi giúp em file ví dụ đây.
có 2 mã đầu không hiển thị lỗi gì bác?

 

[doveandrose]

cái file đầu bạn đưa lên bảng bắt đầu từ dòng 3 rồi giờ file này bảng bắt đầu từ dòng 1 thì code chạy sai đâu có oan ức gì ?
sửa lại theo code này

Public Sub hello()
Dim arr As Variant, r As Long, rsArr As Variant, c As Long, tempStr As String
arr = Sheet1.UsedRange.Value
ReDim rsArr(1 To UBound(arr) - 1, 1 To UBound(arr, 2) + 1)
For r = 2 To UBound(arr) - 1
    rsArr(r, 1) = arr(r, 1)
    rsArr(r, 2) = arr(r + 1, 1)
    For c = 2 To UBound(arr, 2) Step 1
        rsArr(1, c + 1) = arr(1, c)
        tempStr = WorksheetFunction.Trim(arr(r, c) & arr(r + 1, c))
        If tempStr = "00" Or tempStr = "11" Then
            rsArr(r, c + 1) = 1
        Else
            If Len(tempStr) > 0 Then rsArr(r, c + 1) = 0
        End If
    Next
Next
Sheet2.Range("A1").Resize(UBound(rsArr) + 20, UBound(rsArr, 2) + 20).ClearContents
Sheet2.Range("A1").Resize(UBound(rsArr), UBound(rsArr, 2)).Value = rsArr
End Sub

 

[qv7tb]

với điều kiện bài 4 bác chỉnh code giúp em xem.

 

[doveandrose]

với điều kiện bài 4 bác chỉnh code giúp em xem.

ở bài #11 tôi đã cảnh báo bạn trước khi tôi làm rồi . nên 1 khi bạn đã xác định là làm theo file thì tôi sẽ không sửa lại theo #4 nữa . chúng ta đâu phải con nít mà lúc thế này lúc thế nọ ...