Lấy dữ liệu từ sheet này sang sheet khác

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
T

tuan16

Thành viên thường trực
Tham gia
28/11/13
Bài viết
269
Được thích
18
Em có 2 sheet tên lần lượt là “ BKL1” và “BKL”. Trong đó sheet” BKL1” là gồm các số liệu và tai cột N có các mã “ 1,2,a, b,c,d” . Nhờ anh chị trong diễn đàn viết giúp code để sang sheet” BKL” tại cột N gõ các mã hiệu tương ứng sẽ lấy được dữ liệu bên sheet” BKL1”. Trong sheet “ BKL1” mã 1 có 1 dòng thì sẽ lấy được 1 dòng dữ liệu tướng ứng sang sheet “ BKL”, trong sheet “ BKL1” mã a có 2 dòng thì sẽ lấy được 2 dòng dữ liệu tướng ứng sang sheet “ BKL”, trong sheet “ BKL1” mã b có 3 dòng thì sẽ lấy được 3 dòng dữ liệu tướng ứng sang sheet “ BKL”,.Tương tự với các mã c, d, 3,4 . Em xin cảm ơn ạ
 

File đính kèm

  • nho gpe.xlsm
    58.2 KB · Đọc: 14
Sắp xếp theo thời gian sắp xếp theo bầu chọn
tuan16 đã viết:
Em có 2 sheet tên lần lượt là “ BKL1” và “BKL”. Trong đó sheet” BKL1” là gồm các số liệu và tai cột N có các mã “ 1,2,a, b,c,d” . Nhờ anh chị trong diễn đàn viết giúp code để sang sheet” BKL” tại cột N gõ các mã hiệu tương ứng sẽ lấy được dữ liệu bên sheet” BKL1”. Trong sheet “ BKL1” mã 1 có 1 dòng thì sẽ lấy được 1 dòng dữ liệu tướng ứng sang sheet “ BKL”, trong sheet “ BKL1” mã a có 2 dòng thì sẽ lấy được 2 dòng dữ liệu tướng ứng sang sheet “ BKL”, trong sheet “ BKL1” mã b có 3 dòng thì sẽ lấy được 3 dòng dữ liệu tướng ứng sang sheet “ BKL”,.Tương tự với các mã c, d, 3,4 . Em xin cảm ơn ạ
Nhấp chuột vào đây để mở rộng...
@tuan16.
Xem file đính kèm
Bạn thử gõ gì đó vào 1 ô của cột N/Sh BKL xem điều gì đã diễn ra.
 

File đính kèm

  • nho gpe (1).xlsm
    29 KB · Đọc: 20
Upvote 0
tuan16 đã viết:
Dạ em cảm ơn ạ.. Để em thử ạ
Nhấp chuột vào đây để mở rộng...
@HUONGHCKT Anh chị xem giúp em phần này với ạ... khi em gõ mã : 1 thì nó lại lên 2 dòng ạ trong khi sheet "BKL1" dữ liệu là 1 dòng ạ.. còn gõ mã :4 thì báo không có trong thư viện ạ.. khi em xóa dòng bên sheet:BKL thì code báo lỗi, và khi gõ mà khác vào thì code không chạy nữa ạ
 

File đính kèm

  • anh 1.png
    anh 1.png
    58.4 KB · Đọc: 10
  • anh 2.png
    anh 2.png
    56.5 KB · Đọc: 10
  • anh 3.png
    anh 3.png
    26.6 KB · Đọc: 10
Lần chỉnh sửa cuối:
Upvote 0
tuan16 đã viết:
@HUONGHCKT Anh chị xem giúp em phần này với ạ... khi em gõ mã : 1 thì nó lại lên 2 dòng ạ trong khi sheet "BKL1" dữ liệu là 1 dòng ạ.. còn gõ mã :4 thì báo không có trong thư viện ạ.. khi em xóa dòng bên sheet:BKL thì code báo lỗi, và khi gõ mà khác vào thì code không chạy nữa ạ
Nhấp chuột vào đây để mở rộng...
Anh chị giúp em thêm phần này nữa với ạ
 
Upvote 0

File đính kèm

  • nho gpe (1) (1).xlsm
    34.8 KB · Đọc: 3
Upvote 0
Kiểu code khác cho thớt thêm chọn lựa,
Click mũi tên cạnh phải cell N1, chọn 1 mục...
 

File đính kèm

  • nho gpe 2222.xlsm
    27.2 KB · Đọc: 11
Upvote 0
HUONGHCKT đã viết:
Xem file đính kèm:
Riêng phần xóa 1 mã nào đó mà lúc trước đã nhập vào thì theo tôi nên xóa toàn bộ dữ liệu đã nhập vào lúc trước.
Nhấp chuột vào đây để mở rộng...
Lưu ý code mã cuối cùng có thể sẽ không chính xác (do không tìm thấy d- ví dụ ở sheet BKL1 ô N10 = C và dữ liệu trải dài đến tận M20 ), không biết bạn chủ thớt có nhận thấy không?Để khác phục tình trạng trên thay code cụ bằng code này:
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo End_Code1
If Not Intersect(Target, Range("N5:N10000")) Is Nothing Then  ' 12 Lµ Ṽ TRƯ CéT T¦¥NG ¦NG LA L
'    Application.EnableEvents = False
    Dim Tm, i&, j, eR As Long, d&, Lr&
    On Error GoTo End_Code2
    Lr = Sheet1.Range("K" & Rows.Count).End(3).Row
    eR = WorksheetFunction.Match(Target.Value, Sheet1.Columns("N"), 0)
    d = Sheet1.Range("N" & eR).End(xlDown).Row
    If Sheet1.Range("N" & eR + 1) = Empty Then
        If d > Lr Then d = Lr Else d = d - 1
    Else
        d = eR
    End If
    Sheet1.Range("A" & eR & ":M" & d).Copy Target.Offset(, -13)
    Sheet1.Range("O" & eR & ":Q" & d).Copy Target.Offset(, 1)
    Application.EnableEvents = True
End If
End_Code1:
Application.EnableEvents = True
Exit Sub
End_Code2:
MsgBox "Kieu trong hoac khong co trong thu vien"
Target.Offset(, 1).Resize(, 12).ClearContents
GoTo End_Code1
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
DeTong đã viết:
Kiểu code khác cho thớt thêm chọn lựa,
Click mũi tên cạnh phải cell N1, chọn 1 mục...
Nhấp chuột vào đây để mở rộng...
dạ em cảm ơn ạ
HUONGHCKT đã viết:
Lưu ý code mã cuối cùng có thể sẽ không chính xác (do không tìm thấy d- ví dụ ở sheet BKL1 ô N10 = C và dữ liệu trải dài đến tận M20 ), không biết bạn chủ thớt có nhận thấy không?Để khác phục tình trạng trên thay code cụ bằng code này:
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo End_Code1
If Not Intersect(Target, Range("N5:N10000")) Is Nothing Then  ' 12 Lµ Ṽ TRƯ CéT T¦¥NG ¦NG LA L
'    Application.EnableEvents = False
    Dim Tm, i&, j, eR As Long, d&, Lr&
    On Error GoTo End_Code2
    Lr = Sheet1.Range("K" & Rows.Count).End(3).Row
    eR = WorksheetFunction.Match(Target.Value, Sheet1.Columns("N"), 0)
    d = Sheet1.Range("N" & eR).End(xlDown).Row
    If Sheet1.Range("N" & eR + 1) = Empty Then
        If d > Lr Then d = Lr Else d = d - 1
    Else
        d = eR
    End If
    Sheet1.Range("A" & eR & ":M" & d).Copy Target.Offset(, -13)
    Sheet1.Range("O" & eR & ":Q" & d).Copy Target.Offset(, 1)
    Application.EnableEvents = True
End If
End_Code1:
Application.EnableEvents = True
Exit Sub
End_Code2:
MsgBox "Kieu trong hoac khong co trong thu vien"
Target.Offset(, 1).Resize(, 12).ClearContents
GoTo End_Code1
End Sub
Nhấp chuột vào đây để mở rộng...
dạ. để em copy vào file kia ạ..cảm ơn anh chị đã giúp đỡ nhiệt tình ạ
Bài đã được tự động gộp:

DeTong đã viết:
Kiểu code khác cho thớt thêm chọn lựa,
Click mũi tên cạnh phải cell N1, chọn 1 mục...
Nhấp chuột vào đây để mở rộng...
dạ em cảm ơn ạ... em mong muốn theo kiểu đã được anh chị @HUONGHCKT giúp rồi ạ
 
Upvote 0
HUONGHCKT đã viết:
Lưu ý code mã cuối cùng có thể sẽ không chính xác (do không tìm thấy d- ví dụ ở sheet BKL1 ô N10 = C và dữ liệu trải dài đến tận M20 ), không biết bạn chủ thớt có nhận thấy không?Để khác phục tình trạng trên thay code cụ bằng code này:
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo End_Code1
If Not Intersect(Target, Range("N5:N10000")) Is Nothing Then  ' 12 Lµ Ṽ TRƯ CéT T¦¥NG ¦NG LA L
'    Application.EnableEvents = False
    Dim Tm, i&, j, eR As Long, d&, Lr&
    On Error GoTo End_Code2
    Lr = Sheet1.Range("K" & Rows.Count).End(3).Row
    eR = WorksheetFunction.Match(Target.Value, Sheet1.Columns("N"), 0)
    d = Sheet1.Range("N" & eR).End(xlDown).Row
    If Sheet1.Range("N" & eR + 1) = Empty Then
        If d > Lr Then d = Lr Else d = d - 1
    Else
        d = eR
    End If
    Sheet1.Range("A" & eR & ":M" & d).Copy Target.Offset(, -13)
    Sheet1.Range("O" & eR & ":Q" & d).Copy Target.Offset(, 1)
    Application.EnableEvents = True
End If
End_Code1:
Application.EnableEvents = True
Exit Sub
End_Code2:
MsgBox "Kieu trong hoac khong co trong thu vien"
Target.Offset(, 1).Resize(, 12).ClearContents
GoTo End_Code1
End Sub
Nhấp chuột vào đây để mở rộng...
đoạn code chạy được khi em copy code vào trong sheet "BKL" ạ... nhưng copy vào thisworkbook thì không chạy được ạ... anh chị có thể giúp thêm khi các sheets mới tạo ra có tên tai cột Q tại sheet "BKL1" thì vẫn lấy được dữ liệu tại tại sheet"BKL1" sang các sheet đó với ạ. Mong anh chị giúp thêm phần này ạ @HUONGHCKT
 

File đính kèm

  • nho gpe.xlsm
    29.9 KB · Đọc: 6
Upvote 0
tuan16 đã viết:
đoạn code chạy được khi em copy code vào trong sheet "BKL" ạ... nhưng copy vào thisworkbook thì không chạy được ạ... anh chị có thể giúp thêm khi các sheets mới tạo ra có tên tai cột Q tại sheet "BKL1" thì vẫn lấy được dữ liệu tại tại sheet"BKL1" sang các sheet đó với ạ. Mong anh chị giúp thêm phần này ạ @HUONGHCKT
Nhấp chuột vào đây để mở rộng...
Theo tôi hiểu thì Code Private Sub Worksheet_Change(ByVal Target As Range) đặt trong ThisWorkbook sẽ không chạy được.
Phải chăng bạn muốn là khi thêm các Sheet khác (ví dụ là sheet ABC , CDE, .... gì đấy) để khi gõ 1 ký tự vào Cột N thì code sẽ chạy như đã chạy trong sheet BKL, mà bạn không cần copy code bắt sẽ kiện ở sheet mới.
Nếu sheet BKL1 là sheet để lấy dữ liệu (ta tạm gọi là Data nguồn) , Để sheet sau này đều chạy được như Private Sub Worksheet_Change(ByVal Target As Range) của sheet BKL
Theo tôi thì :
1/ Hình như là viết 1 class modulle là thực hiện được ý tưởng trên thì phải. Cái này thì tôi botay.com xin cờ trắng.
2/ bạn dùng hàm người dùng (hàm tự tạo-UDF). Khi ấy bạn chỉ cần gõ hàm vào bất cú ô nào và đưa tham số đúng là sẽ cho ra kết quả. Ví Dụ = LayDL("C") và nhấn Enter.
3/Viết 1 Public sub để lấy dữ liệu với tham số là 1 Range
Mã: 
Public Sub CopyDL(ByVal Rng As Range)
'    Application.EnableEvents = False
    Dim Tm, i&, j, eR As Long, d&, Lr&
    On Error GoTo End_Code2
If Not Rng Is Nothing Then
    Lr = Sheet1.Range("K" & Rows.Count).End(3).Row
    eR = WorksheetFunction.Match(Rng.Value, Sheet1.Columns("N"), 0)
    d = Sheet1.Range("N" & eR).End(xlDown).Row
    If Sheet1.Range("N" & eR + 1) = Empty Then
        If d > Lr Then d = Lr Else d = d - 1
    Else
        d = eR
    End If
    Sheet1.Range("A" & eR & ":M" & d).Copy Rng.Offset(, -13)
    Sheet1.Range("O" & eR & ":Q" & d).Copy Rng.Offset(, 1)
    Application.EnableEvents = True
End If
End_Code1:
Application.EnableEvents = True
Exit Sub
End_Code2:
MsgBox "Kieu trong hoac khong co trong thu vien"
Rng.Offset(, 1).Resize(, 12).ClearContents
GoTo End_Code1
End Sub
Sau đó khi them các sheets mới bạn Bạn chỉ việc copy đoạn code dưới đây và paste vào module sheet.
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("N5:N10000")) Is Nothing Then
    Call CopyDL(Target)
End If
End Sub
Và từ bây giờ khi bạn gõ vào cột N thì đoạn code Private Sub Worksheet_Change(ByVal Target As Range) sẽ chạy.

@All: Mong các anh, chị, em... ghé xem bài và cho ý kiến, thực hiện ý tưởng trên và khai sáng cho tôi và có ai đó nữa cần thêm tư liệu học tập.
Trân trọng cảm ơn
 
Upvote 0
HUONGHCKT đã viết:
Theo tôi hiểu thì Code Private Sub Worksheet_Change(ByVal Target As Range) đặt trong ThisWorkbook sẽ không chạy được.
Phải chăng bạn muốn là khi thêm các Sheet khác (ví dụ là sheet ABC , CDE, .... gì đấy) để khi gõ 1 ký tự vào Cột N thì code sẽ chạy như đã chạy trong sheet BKL, mà bạn không cần copy code bắt sẽ kiện ở sheet mới.
Nếu sheet BKL1 là sheet để lấy dữ liệu (ta tạm gọi là Data nguồn) , Để sheet sau này đều chạy được như Private Sub Worksheet_Change(ByVal Target As Range) của sheet BKL
Theo tôi thì :
1/ Hình như là viết 1 class modulle là thực hiện được ý tưởng trên thì phải. Cái này thì tôi botay.com xin cờ trắng.
2/ bạn dùng hàm người dùng (hàm tự tạo-UDF). Khi ấy bạn chỉ cần gõ hàm vào bất cú ô nào và đưa tham số đúng là sẽ cho ra kết quả. Ví Dụ = LayDL("C") và nhấn Enter.
3/Viết 1 Public sub để lấy dữ liệu với tham số là 1 Range
Mã: 
Public Sub CopyDL(ByVal Rng As Range)
'    Application.EnableEvents = False
    Dim Tm, i&, j, eR As Long, d&, Lr&
    On Error GoTo End_Code2
If Not Rng Is Nothing Then
    Lr = Sheet1.Range("K" & Rows.Count).End(3).Row
    eR = WorksheetFunction.Match(Rng.Value, Sheet1.Columns("N"), 0)
    d = Sheet1.Range("N" & eR).End(xlDown).Row
    If Sheet1.Range("N" & eR + 1) = Empty Then
        If d > Lr Then d = Lr Else d = d - 1
    Else
        d = eR
    End If
    Sheet1.Range("A" & eR & ":M" & d).Copy Rng.Offset(, -13)
    Sheet1.Range("O" & eR & ":Q" & d).Copy Rng.Offset(, 1)
    Application.EnableEvents = True
End If
End_Code1:
Application.EnableEvents = True
Exit Sub
End_Code2:
MsgBox "Kieu trong hoac khong co trong thu vien"
Rng.Offset(, 1).Resize(, 12).ClearContents
GoTo End_Code1
End Sub
Sau đó khi them các sheets mới bạn Bạn chỉ việc copy đoạn code dưới đây và paste vào module sheet.
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("N5:N10000")) Is Nothing Then
    Call CopyDL(Target)
End If
End Sub
Và từ bây giờ khi bạn gõ vào cột N thì đoạn code Private Sub Worksheet_Change(ByVal Target As Range) sẽ chạy.

@All: Mong các anh, chị, em... ghé xem bài và cho ý kiến, thực hiện ý tưởng trên và khai sáng cho tôi và có ai đó nữa cần thêm tư liệu học tập.
Trân trọng cảm ơn
Nhấp chuột vào đây để mở rộng...
Dạ vâng đúng rồi ạ... Kiểu mình thêm 1 sheet mới có tên khác thì vẫn chạy được code mà mình không phải copy và dán copy kia vào trong sheet mới ạ.mà các sheet mới có tên đặt lần lượt như trong cột Q của sheet " BKl1" ạ
 
Upvote 0
HUONGHCKT đã viết:
Theo tôi hiểu thì Code Private Sub Worksheet_Change(ByVal Target As Range) đặt trong ThisWorkbook sẽ không chạy được.
Phải chăng bạn muốn là khi thêm các Sheet khác (ví dụ là sheet ABC , CDE, .... gì đấy) để khi gõ 1 ký tự vào Cột N thì code sẽ chạy như đã chạy trong sheet BKL, mà bạn không cần copy code bắt sẽ kiện ở sheet mới.
Nếu sheet BKL1 là sheet để lấy dữ liệu (ta tạm gọi là Data nguồn) , Để sheet sau này đều chạy được như Private Sub Worksheet_Change(ByVal Target As Range) của sheet BKL
Theo tôi thì :
1/ Hình như là viết 1 class modulle là thực hiện được ý tưởng trên thì phải. Cái này thì tôi botay.com xin cờ trắng.
2/ bạn dùng hàm người dùng (hàm tự tạo-UDF). Khi ấy bạn chỉ cần gõ hàm vào bất cú ô nào và đưa tham số đúng là sẽ cho ra kết quả. Ví Dụ = LayDL("C") và nhấn Enter.
3/Viết 1 Public sub để lấy dữ liệu với tham số là 1 Range
Mã: 
Public Sub CopyDL(ByVal Rng As Range)
'    Application.EnableEvents = False
    Dim Tm, i&, j, eR As Long, d&, Lr&
    On Error GoTo End_Code2
If Not Rng Is Nothing Then
    Lr = Sheet1.Range("K" & Rows.Count).End(3).Row
    eR = WorksheetFunction.Match(Rng.Value, Sheet1.Columns("N"), 0)
    d = Sheet1.Range("N" & eR).End(xlDown).Row
    If Sheet1.Range("N" & eR + 1) = Empty Then
        If d > Lr Then d = Lr Else d = d - 1
    Else
        d = eR
    End If
    Sheet1.Range("A" & eR & ":M" & d).Copy Rng.Offset(, -13)
    Sheet1.Range("O" & eR & ":Q" & d).Copy Rng.Offset(, 1)
    Application.EnableEvents = True
End If
End_Code1:
Application.EnableEvents = True
Exit Sub
End_Code2:
MsgBox "Kieu trong hoac khong co trong thu vien"
Rng.Offset(, 1).Resize(, 12).ClearContents
GoTo End_Code1
End Sub
Sau đó khi them các sheets mới bạn Bạn chỉ việc copy đoạn code dưới đây và paste vào module sheet.
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("N5:N10000")) Is Nothing Then
    Call CopyDL(Target)
End If
End Sub
Và từ bây giờ khi bạn gõ vào cột N thì đoạn code Private Sub Worksheet_Change(ByVal Target As Range) sẽ chạy.

@All: Mong các anh, chị, em... ghé xem bài và cho ý kiến, thực hiện ý tưởng trên và khai sáng cho tôi và có ai đó nữa cần thêm tư liệu học tập.
Trân trọng cảm ơn
Nhấp chuột vào đây để mở rộng...
Em chưa chạy thử, mới nhìn sơ qua thấy hình như thừa một dấu nháy đơn ở đầu dòng thứ hai thì phải anh ạ.
 
Upvote 0
HUONGHCKT đã viết:
Thế hay là bạn muốn sheet BKL1 tách thành các sheet theo tên có trong cột trong sheet
Nhấp chuột vào đây để mở rộng...

HUONGHCKT đã viết:
Thế hay là bạn muốn sheet BKL1 tách thành các sheet theo tên có trong cột N/Sh BKL1
Nhấp chuột vào đây để mở rộng...
Dạ... Em muốn sau các sheet có tên là BKl2,BKl3... Đến Bkl5 em có đặt tên trong cột Q của sheet Bkl1 cũng sẽ lấy được dữ liệu bên sheet Bkl1 như sheet BKL mà đoạn code trên anh chị đã code giúp ạ
 
Upvote 0
tuan16 đã viết:
Dạ... Em muốn sau các sheet có tên là BKl2,BKl3... Đến Bkl5 em có đặt tên trong cột Q của sheet Bkl1 cũng sẽ lấy được dữ liệu bên sheet Bkl1 như sheet BKL mà đoạn code trên anh chị đã code giúp ạ
Nhấp chuột vào đây để mở rộng...
Trong khi chờ đợi các anh chị, em khác viết cho 1 class module bạn thực hiện như 3/ của bài #12. tức là khi tạo thêm 1 sheet mới bạn chỉ việc copy cái đoạn code bắt sự kiện thay đổi cột N là được mà.
 
Upvote 0
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

S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
Trả lời
0
Đọc
5
shnhatha221108
S
T
Không hiện dữ liệu ở ô công thức
Trả lời
3
Đọc
46
thien-16
T
H
Kết nối vba với Database host (hiện tại đang làm host web)
Trả lời
1
Đọc
65
befaint
befaint
trantrimmo
Xin code VBA xuất pdf từ 3 sheet theo lấy thông tin theo tên sheet ạ.
Trả lời
0
Đọc
62
trantrimmo
trantrimmo
hoangtran1176
  • Question
Xuất dữ liệu thông tin khi có mã sản phẩm trùng nhau.
Trả lời
12
Đọc
216
hoangtran1176
hoangtran1176
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