Code tổng hợp các giá trị rời rạc (1 người xem)

  • Thread starter Thread starter 1986QV
  • Ngày gửi Ngày gửi
Elx Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
1986QV

1986QV

Thành viên hoạt động
Tham gia
15/5/12
Bài viết
114
Được thích
6
Nghề nghiệp
Kỹ sư
Em có bài toán tổng hợp hay ghép các dữ liệu rời thành dữ liệu chung. em có các giá trị rời ở sheet này ghép lại để giá trị ấy có ý nghĩa và được mô tả cụ thể như file ví dụ, mong các bác coi và cho em cái code.
Cảm ơn GPE và mọi người quan tâm giúp đỡ em!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
1986QV đã viết:
Em có bài toán tổng hợp hay ghép các dữ liệu rời thành dữ liệu chung. em có các giá trị rời ở sheet này ghép lại để giá trị ấy có ý nghĩa và được mô tả cụ thể như file ví dụ, mong các bác coi và cho em cái code.
Cảm ơn GPE và mọi người quan tâm giúp đỡ em!
Nhấp chuột vào đây để mở rộng...

Thử xem đúng ko nha
Mã: 
Sub GHEP()
Dim DL1, DL2 As Variant, KQ()
DL1 = Sheet1.[A2:b9].Value
DL2 = Sheet2.[A2:b9].Value
ReDim KQ(1 To UBound(DL1) * UBound(DL1), 1 To 2)
For I = 1 To UBound(DL1)
    For J = 1 To UBound(DL2)
        K = K + 1
        KQ(K, 1) = DL1(I, 1) & DL2(J, 1)
        KQ(K, 2) = DL1(I, 2) & DL2(J, 2)
    Next
Next
Sheet3.[A2:b1000].ClearContents
Sheet3.[A2].Resize(K, 2).Value = KQ
End Sub
 
Upvote 0
Cảm ơn bác nha. nhưng chỉ đúng theo yêu cầu 1 là với 2 cột, với n cột dữ liệu 1 với n cột dữ liệu 2 thì chưa được bác ah! Bác nghiên cứu giúp em trường hợp này.
Cảm ơn bác, GPE!
 
Upvote 0
1986QV đã viết:
Cảm ơn bác nha. nhưng chỉ đúng theo yêu cầu 1 là với 2 cột, với n cột dữ liệu 1 với n cột dữ liệu 2 thì chưa được bác ah! Bác nghiên cứu giúp em trường hợp này.
Cảm ơn bác, GPE!
Nhấp chuột vào đây để mở rộng...
thử vận may với code sau xem thế nào :
Mã: 
Option Explicit
Private ArrDL1(), ArrDL2(), ArrTK()
'===============================================================
Sub Ghep()
'Sheet1 la DL1, sheet2 la DL2,sheet3 la sheetTK
On Error GoTo handle
    ArrDL1 = Sheet1.Range("A2").CurrentRegion.Offset(1).Value
    ArrDL2 = Sheet2.Range("A2").CurrentRegion.Offset(1).Value
    ReDim ArrTK(1 To (UBound(ArrDL1, 1) - 1) * (UBound(ArrDL2, 1) - 1), 1 To UBound(ArrDL1, 2))
    try (1)
    With Sheet3
        .Range("A2").CurrentRegion.Offset(1).ClearContents
        .Range("A2").Resize(UBound(ArrTK, 1), UBound(ArrTK, 2)) = ArrTK
    End With
handle:
 If Err Then MsgBox Err.Description
End Sub
'=============================================================================
Sub try(iC As Long)
    Dim iR&, tmp, jR&, i&
        For iR = 1 To UBound(ArrDL1, 1)
            tmp = ArrDL1(iR, iC)
            If Len(tmp) Then
                For i = 1 To UBound(ArrDL2, 1) - 1
                    jR = jR + 1
                    ArrTK(jR, iC) = tmp & ArrDL2(i, iC)
                Next
            End If
        Next
        If iC < UBound(ArrTK, 2) Then try (iC + 1)
End Sub
copy code trên vào module nào đó chạy sub ghep()
 
Upvote 0
1986QV đã viết:
Cảm ơn bác nha. nhưng chỉ đúng theo yêu cầu 1 là với 2 cột, với n cột dữ liệu 1 với n cột dữ liệu 2 thì chưa được bác ah! Bác nghiên cứu giúp em trường hợp này.
Cảm ơn bác, GPE!
Nhấp chuột vào đây để mở rộng...

nếu có thêm một sheet nữa thì nó ghép ra sao?
tôi chưa hình dung ra, 1 giá trị ở sheet1 ghép với 9 giá trị ở sheet2 rồi 9 giá trị mới tạo thàng này ghép với 9 giá trị của sheet3,
như vậy với 1 giá trị ở shéet1 tạo thành 9*9=27, nếu có tiếp sheet thứ 4 nó tiếp tục tăng thêm 9 lần nữa 9*27?
khó nhỉ? tôi chưa hình dung ra
 
Upvote 0
Let'GâuGâu đã viết:
nếu có thêm một sheet nữa thì nó ghép ra sao?
tôi chưa hình dung ra, 1 giá trị ở sheet 1 ghép với 9 giá trị ở sheet 2 rồi 9 giá trị mới tạo thành này ghép với 9 giá trị của sheet 3,
như vậy với 1 giá trị ở shéet 1 tạo thành 9*9=27, nếu có tiếp sheet thứ 4 nó tiếp tục tăng thêm 9 lần nữa 9*27?
khó nhỉ? tôi chưa hình dung ra
Nhấp chuột vào đây để mở rộng...
Ví dụ như sau bác này: Sheet 1 có 1000 cột mỗi cột có 500 hàng ghép với sheet 2 có 1000 cột mỗi cột 300 hàng như vậy 1000*1000 vậy mà bác.
 
Upvote 0
1986QV đã viết:
Ví dụ như sau bác này: Sheet 1 có 1000 cột mỗi cột có 500 hàng ghép với sheet 2 có 1000 cột mỗi cột 300 hàng như vậy 1000*1000 vậy mà bác.
Nhấp chuột vào đây để mở rộng...

thì thử như vậy xem có được ko
Mã: 
Sub GHEP()
Dim DL1, DL2 As Variant, KQ()
With Sheet1
    DL1 = .[A2].Resize(.[a10000].End(3).Row, .[iv2].End(1).Column).Value
End With
With Sheet2
    DL2 = .[A2].Resize(.[a10000].End(3).Row, .[iv2].End(1).Column).Value
End With

ReDim KQ(1 To UBound(DL1) * UBound(DL2), 1 To UBound(DL1, 2))
For I = 1 To UBound(DL1)
    For J = 1 To UBound(DL2)
        K = K + 1
        For C = 1 To UBound(DL1, 2)
            KQ(K, C) = DL1(I, C) & DL2(J, C)
        Next
    Next
Next
Sheet3.[A2:c1000].ClearContents
Sheet3.[A2].Resize(K, UBound(DL1, 2)).Value = KQ
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
em chạy rồi có những số và chữ như số 0 thì mất luôn nếu đứng ở đầu cột trong sheet 3 sau khi ghép, hai nữa bị lỗi khi nhân nếu cột 1 sheet 1 là 50 hàng nhân 20 hàng thuộc cột 1 sheet 2 cho ra 1000 nhưng đây cho ra ba ngàn mấy. bác coi xem có phải do code lỗi không giúp e.
thanks bác
 
Upvote 0
1986QV đã viết:
em chạy rồi có những số và chữ như số 0 thì mất luôn nếu đứng ở đầu cột trong sheet 3 sau khi ghép, hai nữa bị lỗi khi nhân nếu cột 1 sheet 1 là 50 hàng nhân 20 hàng thuộc cột 1 sheet 2 cho ra 1000 nhưng đây cho ra ba ngàn mấy. bác coi xem có phải do code lỗi không giúp e.
thanks bác
Nhấp chuột vào đây để mở rộng...
đã thử code bài #4 tôi viết chưa ??
 
Upvote 0
1986QV đã viết:
em chạy rồi có những số và chữ như số 0 thì mất luôn nếu đứng ở đầu cột trong sheet 3 sau khi ghép, hai nữa bị lỗi khi nhân nếu cột 1 sheet 1 là 50 hàng nhân 20 hàng thuộc cột 1 sheet 2 cho ra 1000 nhưng đây cho ra ba ngàn mấy. bác coi xem có phải do code lỗi không giúp e.
thanks bác
Nhấp chuột vào đây để mở rộng...

tôi đọc tới đọc lùi hoài mà vẫn ko hiểu vì sao nó xác định dư một phần tử trong mảng?
thôi kệ đem trừ đi một vậy
Mã: 
Sub GHEP()
Dim DL1, DL2 As Variant, KQ()
With Sheet1
    DL1 = .[A2].Resize(.[a10000].End(3).Row, .[iv2].End(1).Column).Value
End With
With Sheet2
    DL2 = .[A2].Resize(.[a10000].End(3).Row, .[iv2].End(1).Column).Value
End With

ReDim KQ(1 To UBound(DL1) * UBound(DL2), 1 To UBound(DL1, 2))
For I = 1 To UBound(DL1) - 1
    For J = 1 To UBound(DL2) - 1
        K = K + 1
        For C = 1 To UBound(DL1, 2)
            KQ(K, C) = DL1(I, C) & DL2(J, C)
        Next
    Next
Next

With Sheet3.[A2].Resize(K, UBound(DL1, 2))
    .ClearContents
    .NumberFormat = "@"
    .Value = KQ
End With
End Sub
 
Upvote 0
Let'GâuGâu đã viết:
tôi đọc tới đọc lùi hoài mà vẫn ko hiểu vì sao nó xác định dư một phần tử trong mảng?
thôi kệ đem trừ đi một vậy
Mã: 
Sub GHEP()
Dim DL1, DL2 As Variant, KQ()
With Sheet1
    DL1 = .[A2].Resize(.[a10000].End(3).Row, .[iv2].End(1).Column).Value
End With
With Sheet2
    DL2 = .[A2].Resize(.[a10000].End(3).Row, .[iv2].End(1).Column).Value
End With

ReDim KQ(1 To UBound(DL1) * UBound(DL2), 1 To UBound(DL1, 2))
For I = 1 To UBound(DL1) - 1
    For J = 1 To UBound(DL2) - 1
        K = K + 1
        For C = 1 To UBound(DL1, 2)
            KQ(K, C) = DL1(I, C) & DL2(J, C)
        Next
    Next
Next

With Sheet3.[A2].Resize(K, UBound(DL1, 2))
    .ClearContents
    .NumberFormat = "@"
    .Value = KQ
End With
End Sub
Nhấp chuột vào đây để mở rộng...

em chạy rồi khả năng code bài bác viết chạy ok hơn cho 2 cột, code này chạy được 1 cột bác ah!
 
Upvote 0
1986QV đã viết:
Em chỉ ví dụ thôi nha. chưa kéo hết. Mà code đã chạy sai đôi chỗ, bác xem giúp
ví như 10*20 thì được 200 dòng đầy thiếu gần 20 dòng bác ah!
Nhấp chuột vào đây để mở rộng...

Bạn vào sheet TK ấn nút button1 !
Xong rồi bạn có thể tô màu hay đánh dấu những dòng nào liệt kê thiếu hay sai không ??
 

File đính kèm

Upvote 0
những phần em bôi vàng là ví dụ thiếu. ở có 109 hàng *11 hàng =1199 nhưng đây có 1080 có nghĩa là thiếu ở điểm A. Bác coi xong chỉnh sửa giúp e.
Thanks bác
 

File đính kèm

Upvote 0
DanTri007 đã viết:
những phần em bôi vàng là ví dụ thiếu. ở có 109 hàng *11 hàng =1199 nhưng đây có 1080 có nghĩa là thiếu ở điểm A. Bác coi xong chỉnh sửa giúp e.
Thanks bác
Nhấp chuột vào đây để mở rộng...
Tôi biết ngay là file up khác file bạn gán code vào !
chẳng phải sửa code gì cả, bạn chỉ cần thêm vào ô A1 ở mỗi sheet DL1,DL2,TK bất kỳ 1 ký tự nào cũng được !
ví dụ:
Sheet DL1 , A1 = DL1
Sheet DL2 , A1 = DL2
Sheet TK, A1 = TK
 
Upvote 0
Let'GâuGâu đã viết:
tôi đọc tới đọc lùi hoài mà vẫn ko hiểu vì sao nó xác định dư một phần tử trong mảng?
thôi kệ đem trừ đi một vậy
Mã: 
Sub GHEP()
Dim DL1, DL2 As Variant, KQ()
With Sheet1
    DL1 = .[A2].Resize(.[a10000].End(3).Row, .[iv2].End(1).Column).Value[COLOR=#ff0000] ' tại vì bắt đầu ở dòng số 2[/COLOR]
End With
With Sheet2
    DL2 = .[A2].Resize(.[a10000].End(3).Row, .[iv2].End(1).Column).Value
End With

...
Nhấp chuột vào đây để mở rộng...

Nếu muốn trừ 1 thì phải trừ ở chỗ ấy:

DL1 = .[A2].Resize(.[a10000].End(3).Row - 1, .[iv2].End(1).Column).Value
 
Upvote 0
1986QV đã viết:
Em có bài toán tổng hợp hay ghép các dữ liệu rời thành dữ liệu chung. em có các giá trị rời ở sheet này ghép lại để giá trị ấy có ý nghĩa và được mô tả cụ thể như file ví dụ, mong các bác coi và cho em cái code.
Cảm ơn GPE và mọi người quan tâm giúp đỡ em!
Nhấp chuột vào đây để mở rộng...

Sử dụng thử File, đặt tên sheet là bất kỳ.
Để biết dữ liệu được gộp từ sheet nào, thì gán tên sheet ở cột cuối bên phải của mỗi sheet cần gộp.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
nếu code ấy gộp lại cho ra bài toán sau các bác xem giúp em trường này xem code chỉnh ra sao.
 

File đính kèm

Upvote 0
1986QV đã viết:
nếu code ấy gộp lại cho ra bài toán sau các bác xem giúp em trường này xem code chỉnh ra sao.
Nhấp chuột vào đây để mở rộng...
chọn vùng A2:C15 sheet DLieu1 rồi run code sau
Mã: 
Sub gap()
Dim c As Range, d As Range, s As Range, a()
Set s = Selection
w = s.Columns.Count
For Each r In s.Rows
    If Cells(r.Row, "E") = "" Then x = x & Cells(r.Row, "E") _
    Else x = Cells(r.Row, "E")
    Set c = Sheets("Dlieu2").Cells.Find(x)
    h = c.MergeArea.Rows.Count
    Set d = c.Offset(, -4).Resize(h, w)
    ReDim a(1 To h, 1 To w)
For i = 1 To h
    For j = 1 To w
        a(i, j) = r.Cells(j) & d(i, j)
    Next
Next
    Sheets("Nhan").[E2].Offset(k).Resize(h, w) = a
    k = k + h
Next
End Sub
 
Upvote 0
1986QV đã viết:
nếu code ấy gộp lại cho ra bài toán sau các bác xem giúp em trường này xem code chỉnh ra sao.
Nhấp chuột vào đây để mở rộng...
Chạy code này xem kết quả ra sao
PHP: 
Public Sub GhepKyTu()
Dim DL1, DL2, KQ() As String, d As Long, r As Long, c As Long, i As Long
DL1 = Sheet1.Range("A2:C15")
DL2 = Sheet2.Range("A2:C15")
ReDim KQ(1 To UBound(DL1) * UBound(DL2), 1 To UBound(DL1, 2))
Sheet3.Range("E2:G" & UBound(KQ)).Clear
For c = 1 To UBound(DL1, 2)
i = 0
For d = 1 To UBound(DL1)
For r = 1 To UBound(DL2)
If (IsNumeric(DL1(d, c)) = True And IsNumeric(DL2(r, c)) = False) Or _
(IsNumeric(DL1(d, c)) = False And IsNumeric(DL2(r, c)) = True) Then
i = i + 1
KQ(i, c) = DL1(d, c) & DL2(r, c)
End If
Next r
Next d
Next c
Sheet3.Range("E2").Resize(UBound(KQ), UBound(KQ, 2)).Value = KQ
End Sub
Viết cho dữ liệu ban đầu là 3 cột
 
Upvote 0
Mình thấy 2 vùng dữ liệu chỉ đổi chỗ cho nhau nên code thế này. Nếu đúng là vậy thì chỉ cần dữ liệu của sheet Dulieu1
Và có thể điều chỉnh vùng dữ liệu của data1 và data2 là được
PHP: 
Sub Main()
Dim data1(), data2()
Dim Res(1 To 65536, 1 To 3), Row As Long
data1 = [A2:C5].Value
data2 = [A6:C15].Value
Ghep data1, data2, Row, Res
Ghep data2, data1, Row, Res
[I2].Resize(Row, 3) = Res
End Sub

PHP: 
Function Ghep(Rng1(), Rng2(), Row As Long, Res())
Dim i As Long, j As Long, n As Byte
For i = 1 To UBound(Rng1)
   For j = 1 To UBound(Rng2)
      Row = Row + 1
      For n = 1 To 3
         Res(Row, n) = Rng1(i, n) & Rng2(j, n)
      Next
   Next
Next
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
quanghai1969 đã viết:
Mình thấy 2 vùng dữ liệu chỉ đổi chỗ cho nhau nên code thế này. Nếu đúng là vậy thì chỉ cần dữ liệu của sheet Dulieu1
Và có thể điều chỉnh vùng dữ liệu của data1 và data2 là được
PHP: 
Sub Main()
Dim data1(), data2()
Dim Res(1 To 65536, 1 To 3), Row As Long
data1 = [A2:C5].Value
data2 = [A6:C15].Value
Ghep data1, data2, Row, Res
Ghep data2, data1, Row, Res
[I2].Resize(Row, 3) = Res
End Sub

PHP: 
Function Ghep(Rng1(), Rng2(), Row As Long, Res())
Dim i As Long, j As Long, n As Byte
For i = 1 To UBound(Rng1)
   For j = 1 To UBound(Rng2)
      Row = Row + 1
      For n = 1 To 3
         Res(Row, n) = Rng1(i, n) & Rng2(j, n)
      Next
   Next
Next
End Function
Nhấp chuột vào đây để mở rộng...
Bác Quanghai1969 gán code vào gửi file giúp em! Em gán rồi mà chạy k được hay do em gán k đúng.
 
Upvote 0
1986QV đã viết:
Bác Quanghai1969 gán code vào gửi file giúp em! Em gán rồi mà chạy k được hay do em gán k đúng.
Nhấp chuột vào đây để mở rộng...
Tính gởi file kèm theo khuyến mãi nhưng vì cái tiếng gọi là bác nên không gởi. Thề rồi. Ai gọi bác hay thầy thì tiễn chân hết.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

P
Lấy dữ liệu, theo điều kiện ngày và cấu trúc 2 bảng tính khác nhau. (3 người xem)
Trả lời
0
Đọc
17
Phamthong0712
P
L
Tính thời gian làm việc thực tế
Trả lời
66
Đọc
14K
YenTon
Y
H
Chia sẻ file in Phiếu điều tra PCGD
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
13
Đọc
637
Phuong7686
P
GPE-Trợ Lý
  • Dán lên cao
[KHẨN] HƯỚNG VỀ ĐỒNG BÀO CHỊU ẢNH HƯỞNG CỦA BÃO YAGI - BẢO YÊN, LÀO CAI (2 người xem)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
91
Đọc
14K
SA_DQ
SA_DQ
SA_DQ
Copilot bình luận về một ván cờ vua
    • Thích
Trả lời
6
Đọc
412
SA_DQ
SA_DQ
92nguyenthanh
  • Question Question
Vba cho file nhập xuất kho (1 người xem)
Trả lời
4
Đọc
119
HUONGHCKT
H
C
Fix lỗi Application.InputBox Type:=8
    • Cười
Trả lời
25
Đọc
618
ptm0412
ptm0412
GPE-Trợ Lý
[GPE] TALK SHOW 08: GIẢI QUYẾT VẤN ĐỀ TỐI ƯU HÓA TRONG EXCEL VỚI CÔNG CỤ SOLVER (2 người xem)
    • Thích
    • Cảm ơn
Trả lời
4
Đọc
3K
DuongLeHung
D
Gà Công Nghệ
Chế độ chính sách cho giáo viên mầm non giữ trẻ khuyết tật
Trả lời
1
Đọc
61
vanle33
vanle33
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
56
Đọc
22K
dunghtgiga
dunghtgiga
L
  • Question Question
Viết code tìm kiếm các file trong Folder
Trả lời
40
Đọc
12K
lan nguyen0987
L
P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi
Trả lời
5
Đọc
112
phongvanvu
P
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
ongke0711
ongke0711
ptm0412
Quá tin tưởng vào AI các thể loại (1 người xem)
    • Cười
Trả lời
4
Đọc
223
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code
Trả lời
6
Đọc
161
ptm0412
ptm0412
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
317
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc.
Trả lời
8
Đọc
291
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (1 người xem)
    • Thích
Trả lời
0
Đọc
3K
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11
    • Thích
    • Yêu thích
Trả lời
1
Đọc
138
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
373
dungpham01
D
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom