Xin hỏi về gộp dữ liệu

Liên hệ QC
vumian

vumian

Mỗi bậc thang là mỗi Cell
Tham gia
12/3/07
Bài viết
267
Được thích
186
Nghề nghiệp
employee only, not a boss
Dear all,

MÌnh có 1 giả thuyết về gộp 2 table, miêu tả như trong file, xin hỏi anh chị, các bác mình làm cách nào cho nhanh, hay và không thiếu xót ?

Có thề dùng hàm, giải pháp và VBA

Cám ơn,

Cập nhật mới : Thêm ví dụ cụ thể
 

File đính kèm

  • Combine database.xls
    19.5 KB · Đọc: 54
Lần chỉnh sửa cuối:
Bài toán của bạn có vẻ trìu tượng đấy. Tớ đọc qua mà không hiểu
 
Bác SA,

Gộp vô A cũng được, hay cho ra 1 sheet mới cũng được, điều quan trọng là nhận biết dữ liệu của A hay B sau khi, và một vài điều ghi ghú như trong file

Thanks bác :)
 
Hãy thử với macro này & cho biết vài thông tin về nó

PHP: 
Option Explicit:                                Option Base 1
 Dim jJ As Long, Jw As Long, lRowA As Long, lRowB As Long
Sub GopDuLieu()
 
 lRowA = Sheets("A").[b65432].End(xlUp).Row
 lRowB = Sheets("B").[b65432].End(xlUp).Row
 ReDim MgDL(lRowB - 2) As Boolean
 With Sheets("A")
    For jJ = 3 To lRowA
        For Jw = 3 To lRowB
            If .Cells(jJ, 2) = Sheets("B").Cells(Jw, 2) Then
                .Cells(jJ, 3) = Sheets("B").Cells(Jw, 3)
                MgDL(Jw - 2) = True:                Exit For
            End If
    Next Jw, jJ
    For Jw = 3 To lRowB
        If Not MgDL(Jw - 2) Then
            .Range("B" & .[b65432].End(xlUp).Row + 1) = Sheets("B").Cells(Jw, 2)
            .Range("C" & .[b65432].End(xlUp).Row) = Sheets("B").Cells(Jw, 3)
        End If
    Next Jw
 End With
End Sub
 
Bác ơi,

Tuy là mang ý nghĩa gộp, nhưng nếu khi gộp thì dữ liệu chủ yếu dựa trên table 2,
Table mới sau khi gộp như ví dụ, thì hạng mục bbb,ccc,ddd không còn mới đúng
Đã đưa table mẫu sau khi gộp vào file, Bác xem giúp

Bác xem lại giúp
 
Lần chỉnh sửa cuối:
(/ậy cho vô sheet mới có tên là 'Gop' vậy

vumian đã viết:
Bác ơi, Tuy là mang ý nghĩa gộp, nhưng nếu khi gộp thì dữ liệu chủ yếu dựa trên table 2,
Table mới sau khi gộp như ví dụ, thì hạng mục bbb,ccc,ddd không còn mới đúng
Đã đưa table mẫu sau khi gộp vào file, Bác xem giúp Bác xem lại giúp
Nhấp chuột vào đây để mở rộng...

PHP: 
 Option Explicit:                                Option Base 1
 Dim jJ As Long, Jw As Long, lRowA As Long, lRowB As Long, lRowG As Long
Sub GopDuLieu()
  
 lRowA = Sheets("A").[b65432].End(xlUp).Row
 lRowB = Sheets("B").[b65432].End(xlUp).Row
 ReDim MgDL(lRowB - 2) As Boolean
 
 With Sheets("Gop")
    .Range("A2:K" & (lRowA + lRowB)).Clear
    Sheets("A").[b2].Resize(1, 9).Copy Destination:=.[b2]
    For jJ = 3 To lRowA
        For Jw = 3 To lRowB
            If Sheets("A").Cells(jJ, 2) = Sheets("B").Cells(Jw, 2) Then
                lRowG = .[b65432].End(xlUp).Row + 1
                Sheets("A").Cells(jJ, 2).Resize(1, 9).Copy _
                    Destination:=.Range("B" & lRowG)
                .Range("C" & lRowG) = Sheets("B").Cells(Jw, 3)
                MgDL(Jw - 2) = True:                Exit For
            End If
    Next Jw, jJ
    For Jw = 3 To lRowB
        If Not MgDL(Jw - 2) Then
            lRowG = .[b65432].End(xlUp).Row + 1
            .Range("B" & lRowG) = Sheets("B").Cells(Jw, 2)
            .Range("C" & lRowG) = Sheets("B").Cells(Jw, 3)
        End If
    Next Jw
 End With
End Sub
 
ý, Bác ơi,

Hehe, Thanks bác nhiều lám, giờ chỉ còn 1 công việc nhỏ nữa thôi, Có hứong đi rồi :)
 
Lần chỉnh sửa cuối:
Nếu muốn chép chung vô sheetA

Thì sửa macro ở #4 như sau:
PHP: 
Option Explicit:                                Option Base 1
 Dim jJ As Long, Jw As Long, lRowA As Long, lRowB As Long
Sub GopDuLieu()
 
 lRowA = Sheets("A").[b65432].End(xlUp).Row
 lRowB = Sheets("B").[b65432].End(xlUp).Row
 ReDim MangB(lRowB - 2) As Boolean: ReDim MangA(lRowA - 2) As Boolean '1'
 Dim Rng As Range
 With Sheets("A")
    For jJ = 3 To lRowA
        For Jw = 3 To lRowB
            If .Cells(jJ, 2) = Sheets("B").Cells(Jw, 2) Then
                .Cells(jJ, 3) = Sheets("B").Cells(Jw, 3):           MangA(jJ - 2) = True '2'
                MangB(Jw - 2) = True:                Exit For
            End If
    Next Jw, jJ
 'Thêm:'
    For jJ = 3 To lRowA
        If Not MangA(jJ - 2) Then
            If Rng Is Nothing Then
                Set Rng = .Cells(jJ, 1)
            Else
                Set Rng = Union(Rng, .Cells(jJ, 1))
        End If:     End If
    Next jJ
    Rng.EntireRow.Delete
'Hết thêm'    
    For Jw = 3 To lRowB
        If Not MangB(Jw - 2) Then
            .Range("B" & .[b65432].End(xlUp).Row + 1) = Sheets("B").Cells(Jw, 2)
            .Range("C" & .[b65432].End(xlUp).Row) = Sheets("B").Cells(Jw, 3)
        End If
    Next Jw
 End With
End Sub
 
Bác SA, bác HYen ơi,

KẾt quả của 2 đoạn code trên ra kết quả giống hệt nhau, nhưng đều mong muốn là hạng ở 2 table giống 100% thì chỉ tồn tại 1 mà thôi,

Kết quả 2 bác ra là 7 dòng, nhưng chỉ cần 5 dòng thôi, vì có 3 dòng trùng đó

Thanks,
vumian
 
Hai bác ơi,

Em ccó 1 lỗi về giải thuật, hai bác mở file xem giúp

Cám ơn nhiều,
 

File đính kèm

  • ThemHangMuc.xls
    26.5 KB · Đọc: 26
Lần chỉnh sửa cuối:
Đối chiếu với cái ni, nha:

PHP: 
Option Explicit
Dim ds6 As Long, ds7 As Long
Dim lRowS6 As Long, lRowS7 As Long

Sub ThemHangMuc()
 lRowS6 = Sheet6.[B65432].End(xlUp).Row
 lRowS7 = Sheet7.[B65432].End(xlUp).Row
With Sheet6 ' Sheet A'
    For ds6 = 9 To lRowS6
        For ds7 = 9 To lRowS7
            If .Range("B" & ds6) = Sheet7.Range("B" & ds7) Then Exit For
         Next ds7
        If ds7 > lRowS7 And WorksheetFunction.Sum(.Range("I" & ds6 & ":S" & ds6)) > 0 Then
9  '            MsgBox ds7, , ds6''
            .Range("B" & ds6 & ":S" & ds6).Copy _
                  Destination:=Sheet7.[B65432].End(xlUp).Offset(1, 0)
        End If
    Next ds6
End With
End Sub
&&&%$R
 
Bạn dùng 1 vòng lặp sẽ nhanh hơn 2 vòng lặp, như sau

vumian đã viết:
Hai bác ơi, Em ccó 1 lỗi về giải thuật, hai bác mở file xem giúp
Cám ơn nhiều,
Nhấp chuột vào đây để mở rộng...

PHP: 
Option Explicit 
Dim ds6 As Long, ds7 As Long 
Dim lRowS6 As Long, lRowS7 As Long 
Dim Timer_ As Double 
 
Sub FindAndCopy()
Dim Rng As Range, Clls As Range
 
  Timer_ = Timer
lRowS7 = Sheet7.[b65432].End(xlUp).Row
With Sheet6
   For ds6 = 9 To .[b65432].End(xlUp).Row
      Set Clls = Sheet7.Columns("B:B").Find(.Cells(ds6, 2), LookIn:=xlValues, _
         LookAt:=xlWhole)
      If Clls Is Nothing Then
         If Rng Is Nothing Then
            Set Rng = .Cells(ds6, 2).Resize(1, 18)
         Else
            Set Rng = Union(Rng, .Cells(ds6, 2).Resize(1, 18))
      End If:           End If
   Next ds6
End With
If Not Rng Is Nothing Then _
   Rng.Copy Destination:=Sheet7.Cells(lRowS7 + 1, 2)
MsgBox Timer - Timer_    'Không quá .015625 gy nếu Sheet7 có 1.000 records dữ liệu'
End Sub
 
Chỉnh sửa lần cuối bởi điều hành viên:
Hai bác ơi,

Code của bác SA, số 9 phía sau 'then', có ý nghĩa gì vậy, chưa thấy bao giờ ?

Sau khi thêm rồi, em muốn tô màu để phân biệt, em thêm dòng code sau lệnh copy,mà nó tô màu bậy :)
PHP: 
Sheet7.Range("B" & ds6 & ":S" & ds6).Font.ColorIndex = 5
 
Lần chỉnh sửa cuối:
1*/ Số 9, cũng như các số khác ở đầu các dòng lệnh dùng để đánh số các dòng lệnh;
Rất có í nghĩa khi cần tìm dòng lệnh bị lỗi
Chúng ta có thể viết & kiểm chứng bằng macro như sau

PHP: 
 Sub BayLoi()
 On Error GoTo LoiCT
 Dim VH As Integer

1     MsgBox "1"
2     MsgBox Str(4 / VH)
3     MsgBox "3"
Err_CT:           Exit Sub
LoiCT:
       Select Case Err
       Case 13
            Resume Next
       Case Else
            MsgBox Error$, , Erl:              Resume Err_CT
       End Select
 End Sub

2*/ Tô màu vùng vừa chép bằng câu lệnh sau:

Mã: 
[B]Sub ThemHangMuc() [/B]
' . . . . . . . . . . . . . .   '
'. . . . . . . .  . . . . . . .  '

9  [COLOR="LightBlue"]'            MsgBox ds7, , ds6'[/COLOR]    
 [COLOR="DarkOrchid"]       .Range("B" & ds6 & ":S" & ds6).Copy _
                  Destination:=Sheet7.[b65432].End(xlUp).Offset(1, 0)[/COLOR]      
      Sheet7.Range("B" & Sheet7.[b65432].End(xlUp).Row & ":S" & _
               Sheet7.[b65432].End(xlUp).Row).Interior.ColorIndex = 5
  [COLOR="darkorchid"]      End If
    Next ds6
End With[/COLOR]
[B]End Sub[/B]
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

M
Tự động chèn số 0
Trả lời
8
Đọc
27K
YENNGUYEN5889
YENNGUYEN5889
V
Phân tích dữ liệu cập nhật giá cổ phiếu và BCTC từ trên Vietstock,cophieu68 hoặc Cafef
Trả lời
1
Đọc
2
Hoàng Tuấn 868
H
J
nhờ hướng dẫn hàm tô màu ngày tháng
Trả lời
13
Đọc
192
NGUYENCONGDUNG2
NGUYENCONGDUNG2
H
Hàm điều kiện lấy thời gian giản cách của từng chuyến xe
Trả lời
6
Đọc
90
Phuocam
Phuocam
solomon2211
PDF Tools giúp ghép, tách, xóa file pdf
    • Thích
    • Yêu thích
Trả lời
19
Đọc
390
huhumalu
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom