[Giúp]: Xin code copy từ sheet này sang sheet khác, với cột chỉ định

[timhieu02]

Em chào các anh chị,

Em có 1 file dữ liệu với nhiều cột, nhưng chỉ cần báo cáo 1 vào cột chủ yếu. Nếu dùng hàm excel tham chiếu lấy từng cột thì sẽ có thể sai sót.
Nên cho em xin code với. Em có đính kèm file ví dụ và kết quả mong muốn sau khi chạy macro.

- Sheet "Data": là data tổng, với nhiều dòng và nhiều cột. Ở đây em chỉ lấy ví dụ 1 ít dữ liệu thôi
- Sheet "Key report": trong đó
-> Dòng số 1: là em sẽ nhập tên cột cần copy dữ liệu sang (tên cột này là tên tương ứng với tên trên thanh A, B, C, D...của excel)
-> Những ô ở dòng dòng số 1 không có nhập tên cột, thì không copy dữ liệu
-> khi copy thì giữ nguyên format dữ liệu như ban đầu ở sheet "Data"
- Sheet "kết quả sau khi chạy macro": là kết quả sau khi chạy macro. Sheet này tham khảo thôi. thật ra sau khi chạy macro, thì dữ liệu sẽ copy sang sheet "Key report" ở trên

Do em có nhiều file dữ liệu khác nhau, nên tên cột cần copy cũng sẽ khác nhau.
Chính vì vậy mà em xin code để khi nhập tên cột thì code sẽ dò và copy dữ lệu những cột đó.

Mong tin từ các anh chị.

 

[SA_DQ]

Bạn chạy Macro này để có kết quả & những mong là không cần chuyển file tới bạn;
Chúc thành công!

Sub CopyCacCotTheoChiDinh()
Dim Rws As Long, J As Integer, Col As Integer

Sheets("Key report").Select
[B3].CurrentRegion.Offset(1).ClearContents 'Xóa Du Liêu Lân Truóc Copy    '
With Sheets("Data")
    Rws = .[B4].CurrentRegion.Rows.Count    'Xác Dinh Sô Dòng Cua DL Cân Copy   '
    For J = 1 To 8
1 'Xác Dinh Côt Tuong Úng Cân Copy Sang:  '
        Col = Switch(J = 1, 1, J = 2, 9, J = 3, 3, J = 4, 13, J = 5, 2, J = 6, 5, J = 7, 13, J = 8, 8)
2 ' Thuc Hiên Viêc Copy:  '
        If J <> 4 Or J <> 7 Then
            .Cells(4, Col).Resize(Rws).Copy Destination:=Cells(4, J)
        End If
    Next J
End With
End Sub

 

[timhieu02]

Bạn chạy Macro này để có kết quả & những mong là không cần chuyển file tới bạn;
Chúc thành công!

Sub CopyCacCotTheoChiDinh()
Dim Rws As Long, J As Integer, Col As Integer

Sheets("Key report").Select
[B3].CurrentRegion.Offset(1).ClearContents 'Xóa Du Liêu Lân Truóc Copy    '
With Sheets("Data")
    Rws = .[B4].CurrentRegion.Rows.Count    'Xác Dinh Sô Dòng Cua DL Cân Copy   '
    For J = 1 To 8
1 'Xác Dinh Côt Tuong Úng Cân Copy Sang:  '
        Col = Switch(J = 1, 1, J = 2, 9, J = 3, 3, J = 4, 13, J = 5, 2, J = 6, 5, J = 7, 13, J = 8, 8)
2 ' Thuc Hiên Viêc Copy:  '
        If J <> 4 Or J <> 7 Then
            .Cells(4, Col).Resize(Rws).Copy Destination:=Cells(4, J)
        End If
    Next J
End With
End Sub

Dạ. em xi lỗi vì giờ này mới trả lời vì em biết anh dậy rất sáng sớm để giúp đỡ code cho em.

Anh ơi, anh đừng giận em. em quên báo là: ở sheet "Key report", row 1, em sẽ điền tên cột bất kỳ, tùy theo mỗi file data của dự án. Dòng 1 này là chính và mấu chốt để copy data từ sheet "Data". Còn row 3 thì không cần quan tâm để chạy code.

Có gì anh chỉnh lại giúp em nhé

Trân trọng.

 

[SA_DQ]

Cái quên báo đó cần thể hiện lại trong file mới, lúc đó may ra mới có Code mới.

 

[Ba Tê]

Dạ. em xi lỗi vì giờ này mới trả lời vì em biết anh dậy rất sáng sớm để giúp đỡ code cho em.

Anh ơi, anh đừng giận em. em quên báo là: ở sheet "Key report", row 1, em sẽ điền tên cột bất kỳ, tùy theo mỗi file data của dự án. Dòng 1 này là chính và mấu chốt để copy data từ sheet "Data". Còn row 3 thì không cần quan tâm để chạy code.

Có gì anh chỉnh lại giúp em nhé

Trân trọng.

- Bạn nên "quên" chuyện ghi theo tên cột A,B,C... mà nên ghi theo số cột 1,2,3... như dòng 4 trong file.
- Tìm đâu ra cái "mả" của sản phẩm, của khách hàng vậy? Quê tôi khi chết, người thân xây cho cái mả tốn nhiều tiền lắm đấy.

 

[SA_DQ]

Một cách khác: Chỉ cần ghi tên trường giống với tên trường của trang 'Data' là được:

Public Sub MyGPE()
 Dim Rng As Range, sRng As Range, Sh As Worksheet
 Dim I As Long, J As Long, R As Long, CoL As Long
     
 Set Sh = ThisWorkbook.Worksheets("Data")
 R = Sh.[b4].CurrentRegion.Rows.Count
 Set Rng = Sh.Range(Sh.[A3], Sh.[A3].End(xlToRight)):
 With Sheets("Key report")
    For J = 1 To 99
        If .Cells(3, J).Value = "" Then
            Exit For
        Else
            Set sRng = Rng.Find(.Cells(3, J).Value, , xlFormulas, xlWhole)
            If Not sRng Is Nothing Then
                Sh.Cells(5, sRng.Column).Resize(R).Copy Destination:=.Cells(4, J)
            End If
        End If
    Next J
 End With
End Sub

 

[timhieu02]

Dạ. em cảm ơn anh @Ba Tê @SA_DQ nhiều lắm.

- Bạn nên "quên" chuyện ghi theo tên cột A,B,C... mà nên ghi theo số cột 1,2,3... như dòng 4 trong file.
- Tìm đâu ra cái "mả" của sản phẩm, của khách hàng vậy? Quê tôi khi chết, người thân xây cho cái mả tốn nhiều tiền lắm đấy.

Hihihi..em cảm ơn anh @Ba Tê ạ. sai lỗi chính tả đúng là tai hại thật!
Anh ơi, em có nổi khổ ở bài toán này, vì file report này, ngoài em ra, còn có 1 số người khác câp nhật nữa. Mà các bạn em chỉ quen việc nhập tên cột A, B, C, ..như trong dòng số 1 ở sheet "Key report". Anh có cách nào giúp em với. Em có đính kèm lại file mẫu ạ.

Bài đã được tự động gộp: 19/7/19

Một cách khác: Chỉ cần ghi tên trường giống với tên trường của trang 'Data' là được:

Public Sub MyGPE()
Dim Rng As Range, sRng As Range, Sh As Worksheet
Dim I As Long, J As Long, R As Long, CoL As Long
    
Set Sh = ThisWorkbook.Worksheets("Data")
R = Sh.[b4].CurrentRegion.Rows.Count
Set Rng = Sh.Range(Sh.[A3], Sh.[A3].End(xlToRight)):
With Sheets("Key report")
    For J = 1 To 99
        If .Cells(3, J).Value = "" Then
            Exit For
        Else
            Set sRng = Rng.Find(.Cells(3, J).Value, , xlFormulas, xlWhole)
            If Not sRng Is Nothing Then
                Sh.Cells(5, sRng.Column).Resize(R).Copy Destination:=.Cells(4, J)
            End If
        End If
    Next J
End With
End Sub

Dạ. em cảm ơn anh @SA_DQ nhiều lắm. Do dữ liệu ở sheet "Data", (data thật tế) sẽ có 1 số cột có các header bị trùng nhau. Và header ở sheet "Key report" , tụi em cần chỉnh lại tên cho rõ nghĩa nữa. Nên em chỉ nhập tên cột A, B, C, ...ở dòng 1 - cần lấy data thôi ạ.

Có gì anh nhín chút thời gian giúp em với. Em có đính kèm lại file mẫu ban đầu ạ

 

[Ba Tê]

Mà các bạn em chỉ quen việc nhập tên cột A, B, C, ..

Bảo các bạn thay đổi thói quen. Nếu không thì để các bạn tự xoay sở.
Tôi chỉ làm được như vậy thôi.

 

[timhieu02]

Bảo các bạn thay đổi thói quen. Nếu không thì để các bạn tự xoay sở.
Tôi chỉ làm được như vậy thôi.

Dạ anh. Chúc anh @Ba Tê ngủ ngon ạ.

 

[SA_DQ]

Giận thì giận, mà thương thì thương; Anh sai đường em không chịu nổi; Anh ơi anh xin dừng có zận dỗi, . . . .

Const Alf As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Sub CopyCacCotTheoMaCotChiDinh()
Dim Rws As Long, J As Integer, Col As Integer

Sheets("Key report").Select
[B3].CurrentRegion.Offset(1).ClearContents
With Sheets("Data")
    Rws = .[B4].CurrentRegion.Rows.Count
    For J = 1 To Cells(1, 35).End(xlToLeft).Column
        Col = InStr(Alf, Cells(1, J).Value)
        If Col Then
            .Cells(4, Col).Resize(Rws).Copy Destination:=Cells(4, J)
        End If
    Next J
End With
End Sub

 

[timhieu02]

Giận thì giận, mà thương thì thương; Anh sai đường em không chịu nổi; Anh ơi anh xin dừng có zận dỗi, . . . .

Const Alf As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Sub CopyCacCotTheoMaCotChiDinh()
Dim Rws As Long, J As Integer, Col As Integer

Sheets("Key report").Select
[B3].CurrentRegion.Offset(1).ClearContents
With Sheets("Data")
    Rws = .[B4].CurrentRegion.Rows.Count
    For J = 1 To Cells(1, 35).End(xlToLeft).Column
        Col = InStr(Alf, Cells(1, J).Value)
        If Col Then
            .Cells(4, Col).Resize(Rws).Copy Destination:=Cells(4, J)
        End If
    Next J
End With
End Sub

Em cảm ơn anh @SA_DQ ! nó đã chạy rồi. Em test thì còn 2 ý nữa là về đích bài toán này của em rồi
- Chỉ cho phép copy những cột được chỉnh định. Hiện tại những cột không có nhập tên cột thì nó tự động copy dữ liệu cột đầu tiên bên sheet "Data"
- Dữ liệu thật tế của em thì có rất nhiều cột (hàng trăm cột), nên nên những tên cột như là "AA", "AB", "ADX", v.v..thì macro không copy được.

Mong anh giúp em thêm tí nữa nhé (Do là cuối tuần, sau khi anh dành thời gian cho gia đình của anh xong, công việc của anh xong, thì anh hãy giúp em sau nhé )

 

[Ba Tê]

Em cảm ơn anh @SA_DQ ! nó đã chạy rồi. Em test thì còn 2 ý nữa là về đích bài toán này của em rồi
- Chỉ cho phép copy những cột được chỉnh định. Hiện tại những cột không có nhập tên cột thì nó tự động copy dữ liệu cột đầu tiên bên sheet "Data"
- Dữ liệu thật tế của em thì có rất nhiều cột (hàng trăm cột), nên nên những tên cột như là "AA", "AB", "ADX", v.v..thì macro không copy được.

Mong anh giúp em thêm tí nữa nhé (Do là cuối tuần, sau khi anh dành thời gian cho gia đình của anh xong, công việc của anh xong, thì anh hãy giúp em sau nhé )

Nếu bạn vẫn "cố chấp" với cách ghi tên cột, A, Z, AB,XFA... thì cũng phải có 1 hàm "dịch" Tên cột thành Số cột mà thôi.
Bạn xem file, trong đó có 1 Hàm "Cùi bắp" để làm chuyện này. (Cùi bắp là vì tôi chưa từng xử chuyện oái oăm này)

 

[khongtu19bk]

Nếu bạn vẫn "cố chấp" với cách ghi tên cột, A, Z, AB,XFA... thì cũng phải có 1 hàm "dịch" Tên cột thành Số cột mà thôi.
Bạn xem file, trong đó có 1 Hàm "Cùi bắp" để làm chuyện này. (Cùi bắp là vì tôi chưa từng xử chuyện oái oăm này)

Với code của anh:

Public Function SoCot(ByVal TenCot As String) As Long
Dim J As Long, X As String
For J = 1 To 1000
    X = Replace(Replace(Cells(1, J).Address, "$", ""), 1, "")
    If X = UCase(TenCot) Then
        SoCot = J
        Exit For
    End If
Next J
End Function

phải chạy vòng lặp 1000 lần. Hơn nữa nếu cột vượt quá 1000 thì không đáp ứng được.
Vì lý do đó, em xin đóng góp code sau:
'Input: Nhập vào tên cột. Ex: AA
'Output: cho ra thông báo số cột bằng SỐ

Sub tuhocvba()
    Dim s As String
    s = "AXA"
    s = s & "$1"
    MsgBox Range(s).Column
End Sub

Kết quả:

 

[befaint]

s = s & "$1"

Không có đô la có được không bạn?

 

[khongtu19bk]

Không có đô la có được không bạn?

Không có đô la thì nghèo thôi, còn vẫn được
Bỏ đô la đi , nhưng đừng quên gõ 1 vào nhé.

Sub tuhocvba()
    Dim s As String
    s = "AXA"
    s = s & "1"
    MsgBox Range(s).Column
End Sub

 

[befaint]

Không có đô la thì nghèo thôi, còn vẫn được
Bỏ đô la đi , nhưng đừng quên gõ 1 vào nhé.

Sub tuhocvba()
    Dim s As String
    s = "AXA"
    s = s & "1"
    MsgBox Range(s).Column
End Sub

Nếu mình chuyển thành một function hoàn chỉnh thì như nào bạn?

 

[khongtu19bk]

Nếu mình chuyển thành một function hoàn chỉnh thì như nào bạn?

'INPUT: ex: AA
'OUTPUT: chi ra cot bang so
'Neu ham co gia tri = 0 tuc la dang bi loi, dia chi cot nhap sai.
Function timdiachicot(ByVal s As String) As integer
    Dim i As Integer
    On Error Resume Next
    timdiachicot = 0
    i = Range(s & "1").Column
    timdiachicot = i
End Function
Sub tuhocvba_2()
    MsgBox timdiachicot("ADFFFF")
End Sub

 

[befaint]

On Error Resume Next

Có cách nào khác ngoài cách dùng lệnh này không bạn? Mình thấy mấy anh lớn tuổi kêu không nên dùng lệnh đó.

 

[khongtu19bk]

Có cách nào khác ngoài cách dùng lệnh này không bạn? Mình thấy mấy anh lớn tuổi kêu không nên dùng lệnh đó.

Mình xin phép dừng thảo luận ở đây vì lý do tiếp tục thảo luận là bất minh.
Tại sao bạn không hỏi mấy anh lớn tuổi, những người kêu bạn không nên dùng lệnh đó ấy.
-Lý do?
-Phương án thay thế?
Áp dụng: Trong trường hợp cụ thể này, dùng lệnh đó thì điều bất an gì sẽ xảy ra?

 

[befaint]

Mình xin phép dừng thảo luận ở đây vì lý do tiếp tục thảo luận là bất minh.

"bất minh"

Nghĩa là: không rõ ràng, có chỗ đáng nghi ngờ.

Ví dụ: 'Quan hệ' bất minh, 'thảo luận' bất minh.

Từ đồng nghĩa: ám muội, đen tối, khuất tất, mờ ám.

Từ trái nghĩa: minh bạch.
---
Đang thảo luận 'lộ thiên' thế này mà lại kêu 'bất minh'. Oan thị bưởi ghê.