Code VBA copy dữ liệu (1 người xem)

Dong Le · 13/10/12

Chào các anh/chị và các bạn,

Nhờ các bạn giúp mình code copy dữ liệu dang sheet khác như yêu cầu mình nêu chi tiết trong file đính kèm. Mình viết được code copy rồi nhưng chưa viết được code đổi ký tự trong cell.

Cảm ơn các bạn nhiều.

Dong Le · 16/10/12

Hai Lúa Miền Tây đã viết:
Code bài #13 đã đúng theo yêu cầu của bạn rồi còn gì.

Xem lại giúp mình với, cũng câu lệnh đó nhưng nó cứ báo lỗi.

Hai Lúa Miền Tây · 16/10/12

Vào cửa sổ code click chọn Tools>Refrences, xong chọn Microsoft ActiveX Data Objects x.x Library (ADO)

[video=youtube;9g8izYUQrnE]http://www.youtube.com/watch?v=9g8izYUQrnE&feature=youtu.be[/video]

ndu96081631 · 16/10/12

Hai Lúa Miền Tây đã viết:
Vào cửa sổ code click chọn Tools>Refrences, xong chọn Microsoft ActiveX Data Objects x.x Library (ADO)

Cách khác: Sửa code thành vầy sẽ khỏi mất công chỉnh gì gì đó trong Reference:

PHP:

Private Sub Worksheet_Activate()
  Dim cn As Object, adoRS As Object
  Set cn = CreateObject("ADODB.Connection")
  Set adoRS = CreateObject("ADODB.Recordset")
  On Error GoTo ErrHandler
  With cn
    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & ThisWorkbook.FullName & _
                        ";Extended Properties=""Excel 8.0;HDR=No;"";"
    .Open
  End With
  With adoRS
    .ActiveConnection = cn
    .Open "SELECT F1, '' as T1,'' as T2, F4,F5,F6,F7,F8, SUM(F9) FROM [Sheet2$A6:I65000] " & _
          "GROUP BY F1, F4,F5,F6,F7,F8 HAVING SUM(F9) >0"
  End With
  Sheets("Sheet1").Range("A6").CopyFromRecordset adoRS
  adoRS.Close: cn.Close
  Set cn = Nothing: Set adoRS = Nothing
  Exit Sub
ErrHandler:
MsgBox Err.Description
End Sub

Dong Le · 16/10/12

Hai Lúa Miền Tây đã viết:
Vào cửa sổ code click chọn Tools>Refrences, xong chọn Microsoft ActiveX Data Objects x.x Library (ADO)

[video=youtube;9g8izYUQrnE]http://www.youtube.com/watch?v=9g8izYUQrnE&feature=youtu.be[/video]

Mình có thể xin Yahoo của bạn Hai Lúa Miền Tây được ko?

Dong Le · 16/10/12

Dong Le đã viết:
Mình có thể xin Yahoo của bạn Hai Lúa Miền Tây được ko?

Xem lại giúp mình code của Sheet "Sum" trong file đính kèm với.

ndu96081631 · 16/10/12

Dong Le đã viết:
Xem lại giúp mình code của Sheet "Sum" trong file đính kèm với.

Chán đồng chí này quá!
Mỗi code sẽ ứng với 1 CSDL nhất định... Giờ sửa tùm lum (tên sheet lẫn cấu trúc dữ liệu) thì làm sao mà code chạy được!
Tốt nhất là: Đưa dữ liệu đúng sự thật lên đây 1 lần luôn, đừng đưa lắt nhắt, lúc vầy lúc khác sẽ mất công cho mọi người

Dong Le · 16/10/12

ndu96081631 đã viết:
Chán đồng chí này quá!
Mỗi code sẽ ứng với 1 CSDL nhất định... Giờ sửa tùm lum (tên sheet lẫn cấu trúc dữ liệu) thì làm sao mà code chạy được!
Tốt nhất là: Đưa dữ liệu đúng sự thật lên đây 1 lần luôn, đừng đưa lắt nhắt, lúc vầy lúc khác sẽ mất công cho mọi người

Xin lỗi bạn vì file nặng, mình nghĩ cắt ra như thế rồi sẽ modify lại cho phù hợp tuy nhiên hàm này hơi phức tạp. code trong sheet "sum" mình đã viết lại nhưng vẫn báo lỗi, lần sau sẽ rút kinh nghiệm, nhờ bạn xem hộ và chỉ lỗi giúp.

ndu96081631 · 16/10/12

Dong Le đã viết:
Xin lỗi bạn vì file nặng, mình nghĩ cắt ra như thế rồi sẽ modify lại cho phù hợp tuy nhiên hàm này hơi phức tạp. code trong sheet "sum" mình đã viết lại nhưng vẫn báo lỗi, lần sau sẽ rút kinh nghiệm, nhờ bạn xem hộ và chỉ lỗi giúp.

Bạn xóa bớt dữ liệu, tôi đồng ý, nhưng ít ra phải giữ lại CẤU TRÚC cho nó giống y chang với dữ liệu thật của bạn chứ!
Ví dụ: Dữ liệu của bạn đặt tại A510000, trong đó A5

5 là tiêu đề. Vậy bạn có thể xóa bớt để chừa lại khoảng 10 dòng ---> Dữ liệu còn lại là A514
Những thứ không được xóa và thay đổi:
- Tiêu đề cột tại các sheet
- Tên sheet
vân vân... Nói chung là không được thay đổi CẤU TRÚC ---> Bạn có hiểu không nhỉ?

Dong Le · 16/10/12

ndu96081631 đã viết:
Bạn xóa bớt dữ liệu, tôi đồng ý, nhưng ít ra phải giữ lại CẤU TRÚC cho nó giống y chang với dữ liệu thật của bạn chứ!
Ví dụ: Dữ liệu của bạn đặt tại A510000, trong đó A55 là tiêu đề. Vậy bạn có thể xóa bớt để chừa lại khoảng 10 dòng ---> Dữ liệu còn lại là A514
Những thứ không được xóa và thay đổi:
- Tiêu đề cột tại các sheet
- Tên sheet
vân vân... Nói chung là không được thay đổi CẤU TRÚC ---> Bạn có hiểu không nhỉ?

Vâng, cảm ơn bạn, mình hiểu rồi. Hiện code ở sheet "copy" đã chạy ok, còn của sheet "Sum" thì nhờ bạn xem giúp mình, file này đã đúng với bản thật của mình rồi.

Hai Lúa Miền Tây · 16/10/12

Hic, lại "lòi" ra cột STT, và chủ hàng, 2 cột này bạn tính sao? có đưa vào điều kiện cộng?

Dong Le · 16/10/12

Hai Lúa Miền Tây đã viết:
Hic, lại "lòi" ra cột STT, và chủ hàng, 2 cột này bạn tính sao? có đưa vào điều kiện cộng?

STT thì có thể automatic được ko bạn? còn chủ hàng thì trùng nhau theo số bill nên đưa vào điều kiện cộng, cột này cũng rất quan trọng.

Hai Lúa Miền Tây · 16/10/12

Dong Le đã viết:
STT thì có thể automatic được ko bạn? còn chủ hàng thì trùng nhau theo số bill nên đưa vào điều kiện cộng, cột này cũng rất quan trọng.

Ban đầu phải nói luôn đỡ phải mất thời gian, bạn thử code sau nhé.

Mã:

Private Sub Worksheet_Activate()
  Dim cn As Object, adoRS As Object
  Set cn = CreateObject("ADODB.Connection")
  Set adoRS = CreateObject("ADODB.Recordset")
  On Error GoTo BaoLoi
        With cn
            .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                           "Data Source=" & ThisWorkbook.FullName & _
                                           ";Extended Properties=""Excel 8.0;HDR=No;"";"
            .Open
        End With
        With adoRS
            .ActiveConnection = cn
            .Open "SELECT '' as T, F2,F3, '' as T1,'' as T2, F6,F7,F8,F9,F10,SUM(F11), F12 FROM [Copy$A6:L65000] " & _
                      "GROUP BY F2,F3, F6,F7,F8,F9,F10,F12 " & _
                      "HAVING SUM(F11) >0"
        End With
        Sheets("Sum").Range("A6").CopyFromRecordset adoRS
        adoRS.Close: cn.Close
        Set cn = Nothing: Set adoRS = Nothing
    Exit Sub
BaoLoi:
MsgBox Err.Description

End Sub

Dong Le · 16/10/12

Hai Lúa Miền Tây đã viết:

Ban đầu phải nói luôn đỡ phải mất thời gian, bạn thử code sau nhé.

Mã:

Private Sub Worksheet_Activate()
  Dim cn As Object, adoRS As Object
  Set cn = CreateObject("ADODB.Connection")
  Set adoRS = CreateObject("ADODB.Recordset")
  On Error GoTo BaoLoi
        With cn
            .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                           "Data Source=" & ThisWorkbook.FullName & _
                                           ";Extended Properties=""Excel 8.0;HDR=No;"";"
            .Open
        End With
        With adoRS
            .ActiveConnection = cn
            .Open "SELECT '' as T, F2,F3, '' as T1,'' as T2, F6,F7,F8,F9,F10,SUM(F11), F12 FROM [Copy$A6:L65000] " & _
                      "GROUP BY F2,F3, F6,F7,F8,F9,F10,F12 " & _
                      "HAVING SUM(F11) >0"
        End With
        Sheets("Sum").Range("A6").CopyFromRecordset adoRS
        adoRS.Close: cn.Close
        Set cn = Nothing: Set adoRS = Nothing
    Exit Sub
BaoLoi:
MsgBox Err.Description

End Sub

Cột A-STT để trống chứ ko nhảy theo thứ tự được à bạn? và ko sum được cột L - So con't hả bạn?

Hai Lúa Miền Tây · 16/10/12

Đáng lẽ tôi làm đến đây bạn phải biết tự vận dụng chứ.

Mã:

Private Sub Worksheet_Activate()
  Dim cn As Object, adoRS As Object
  Set cn = CreateObject("ADODB.Connection")
  Set adoRS = CreateObject("ADODB.Recordset")
  On Error GoTo BaoLoi
        With cn
            .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                           "Data Source=" & ThisWorkbook.FullName & _
                                           ";Extended Properties=""Excel 8.0;HDR=No;"";"
            .Open
        End With
        With adoRS
            .ActiveConnection = cn
            .Open "SELECT '' as T,F2,F3,'' as T1,'' as T2, F6,F7,F8,F9,F10,SUM(F11), Sum(F12) FROM [Copy$A6:L65000] " & _
                      "GROUP BY F2,F3,F6,F7,F8,F9,F10 " & _
                      "HAVING SUM(F11) >0"
        End With
        With Sheets("Sum")
            .Range("A6:L65000").ClearContents
            .Range("A6").CopyFromRecordset adoRS
                With .Range("A6:A" & .Range("B65000").End(xlUp).Row)
                       .FormulaR1C1 = "=ROW()-5"
                       .Value = .Value
                End With
        End With
        adoRS.Close: cn.Close
        Set cn = Nothing: Set adoRS = Nothing
    Exit Sub
BaoLoi:
MsgBox Err.Description

End Sub

Ba Tê · 16/10/12

Dong Le đã viết:
Cột A-STT để trống chứ ko nhảy theo thứ tự được à bạn? và ko sum được cột L - So con't hả bạn?

Biết VBA đã khó, làm bằng ADODB càng khó hơn nếu chưa biết được chút gì về nó.
Nếu là tôi thì làm bằng VBA cho dễ đọc.

Dong Le · 16/10/12

Hai Lúa Miền Tây đã viết:

Đáng lẽ tôi làm đến đây bạn phải biết tự vận dụng chứ.

Mã:

Private Sub Worksheet_Activate()
  Dim cn As Object, adoRS As Object
  Set cn = CreateObject("ADODB.Connection")
  Set adoRS = CreateObject("ADODB.Recordset")
  On Error GoTo BaoLoi
        With cn
            .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                           "Data Source=" & ThisWorkbook.FullName & _
                                           ";Extended Properties=""Excel 8.0;HDR=No;"";"
            .Open
        End With
        With adoRS
            .ActiveConnection = cn
            .Open "SELECT '' as T,F2,F3,'' as T1,'' as T2, F6,F7,F8,F9,F10,SUM(F11), Sum(F12) FROM [Copy$A6:L65000] " & _
                      "GROUP BY F2,F3,F6,F7,F8,F9,F10 " & _
                      "HAVING SUM(F11) >0"
        End With
        With Sheets("Sum")
            .Range("A6:L65000").ClearContents
            .Range("A6").CopyFromRecordset adoRS
                With .Range("A6:A" & .Range("B65000").End(xlUp).Row)
                       .FormulaR1C1 = "=ROW()-5"
                       .Value = .Value
                End With
        End With
        adoRS.Close: cn.Close
        Set cn = Nothing: Set adoRS = Nothing
    Exit Sub
BaoLoi:
MsgBox Err.Description

End Sub

Cảm ơn bạn nhiều. code khó quá bạn ạ. mình thì mới tập tọe thôi.

Dong Le · 19/10/12

Hai Lúa Miền Tây đã viết:

.

Mã:

Private Sub Worksheet_Activate()
  Dim cn As Object, adoRS As Object
  Set cn = CreateObject("ADODB.Connection")
  Set adoRS = CreateObject("ADODB.Recordset")
  On Error GoTo BaoLoi
        With cn
            .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                           "Data Source=" & ThisWorkbook.FullName & _
                                           ";Extended Properties=""Excel 8.0;HDR=No;"";"
            .Open
        End With
        With adoRS
            .ActiveConnection = cn
            .Open "SELECT '' as T,F2,F3,'' as T1,'' as T2, F6,F7,F8,F9,F10,SUM(F11), Sum(F12) FROM [Copy$A6:L65000] " & _
                      "GROUP BY F2,F3,F6,F7,F8,F9,F10 " & _
                      "HAVING SUM(F11) >0"
        End With
        With Sheets("Sum")
            .Range("A6:L65000").ClearContents
            .Range("A6").CopyFromRecordset adoRS
                With .Range("A6:A" & .Range("B65000").End(xlUp).Row)
                       .FormulaR1C1 = "=ROW()-5"
                       .Value = .Value
                End With
        End With
        adoRS.Close: cn.Close
        Set cn = Nothing: Set adoRS = Nothing
    Exit Sub
BaoLoi:
MsgBox Err.Description

End Sub

Bác Hai lúa miền Tây ơi! giúp mình cái này với, mình ghi cụ thể trong file đính kèm bên dưới.

Hai Lúa Miền Tây · 19/10/12

Dong Le đã viết:
Bác Hai lúa miền Tây ơi! giúp mình cái này với, mình ghi cụ thể trong file đính kèm bên dưới.

Bạn chỉnh cột đó về dạng Text là được.

Dong Le · 19/10/12

Hai Lúa Miền Tây đã viết:
Bạn chỉnh cột đó về dạng Text là được.[/QUOT

Mình đã làm được, cảm ơn bác Hai Lúa Miền Tây.

Dong Le · 26/10/12

Dong Le đã viết:
Cảm ơn bạn nhiều. code khó quá bạn ạ. mình thì mới tập tọe thôi.

Chào bác Hai Lúa Miền Tây, bác giúp mình câu lệnh này với, mình đã viết lệnh copy sang sheet khác và check trùng, giờ muốn thêm điều kiện là khi copy sang nó sắp xếp theo thứ tự cột ngày tháng thì dùng câu lệnh gì bạn?

Code VBA copy dữ liệu (1 người xem)

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

Thành viên chính thức

File đính kèm

Thành viên chính thức

File đính kèm

❆❆❆❆❆❆❆❆

Huyền thoại GPE

Thành viên chính thức

Thành viên chính thức

File đính kèm

Huyền thoại GPE

Thành viên chính thức

Huyền thoại GPE

Thành viên chính thức

❆❆❆❆❆❆❆❆

Thành viên chính thức

❆❆❆❆❆❆❆❆

Thành viên chính thức

❆❆❆❆❆❆❆❆

Cạo Rồi Khỏi Gội

File đính kèm

Thành viên chính thức

Thành viên chính thức

File đính kèm

❆❆❆❆❆❆❆❆

File đính kèm

Thành viên chính thức

Thành viên chính thức

File đính kèm

Đếm ngược thời gian