Help: giúp code dùm em " khi nhấn save tự copy data dán qua sheet khác" (1 người xem)

[Thiện Nguyễn Minh]

Hi all!
Như tiêu đề, mình cần được giúp đỡ.
Hiện tại mình đang phát triển file excel phần lớn là dùng công thức và một ít macro, do mình không rành nhiều về macro và code nên bị bí ngay đoạn này.
Mình cần điều kiện là khi nhấn save, dữ liệu sẽ tự động được copy qua sheet khác, quan trọng là vùng dữ liệu sẽ biến đổi, khi là 10 cell, khi 25cell...vv
Và khi copy qua sheet khác cần phải copy nối tiếp chứ không đè lên dữ liệu cũ.
Xin cảm ơn và hóng!

 

[HeSanbi]

Thử xem đúng ý bạn không

Hoặc Copy Code này vào khu vực Code của thisWorkbook nằm chung với các sheets:
(không khuyên dùng)
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim arr
arr = Sheets("sheet1").Range("B2:B" & Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row)
Sheets("Data").Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arr)) = arr
End Sub
Với code này Ấn Save của chương trình sẽ thực hiện. không thì phải thêm ThisWorkbook.SAVE vào một macro rồi thực thi

Sub savetocopydata()
    Dim arr
    ThisWorkbook.SAVE

    If ThisWorkbook.Saved Then _
        arr = Sheets("sheet1").Range("B2:B" & Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row): _
        Sheets("Data").Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arr)) = arr
End Sub

 

[Thiện Nguyễn Minh]

Thử xem đúng ý bạn không

Hoặc Copy Code này vào khu vực Code của thisWorkbook nằm chung với các sheets:
(không khuyên dùng)
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim arr
arr = Sheets("sheet1").Range("B2:B" & Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row)
Sheets("Data").Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arr)) = arr
End Sub
Với code này Ấn Save của chương trình sẽ thực hiện. không thì phải thêm ThisWorkbook.SAVE vào một macro rồi thực thi

Sub savetocopydata()
    Dim arr
    ThisWorkbook.SAVE

    If ThisWorkbook.Saved Then _
        arr = Sheets("sheet1").Range("B2:B" & Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row): _
        Sheets("Data").Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arr)) = arr
End Sub

Cảm ơn bạn rất nhiều, đúng với ý mình rồi, nhưng bạn có thể giúp mình edit lại mình muốn copy nhiều hơn 1 vùng đó, vùng của mình cần nhiều cột hơn.
Xin lỗi đã làm phiền bạn, cảm ơn bạn!

 

[HeSanbi]

Cảm ơn bạn rất nhiều, đúng với ý mình rồi, nhưng bạn có thể giúp mình edit lại mình muốn copy nhiều hơn 1 vùng đó, vùng của mình cần nhiều cột hơn.
Xin lỗi đã làm phiền bạn, cảm ơn bạn!

- "B2:B" - đang ở cột B, muốn nhiều cột thì Đổi "B2:C", D, E,.... Nếu là cột động thì dùng (xlLeft) để trả về Address column thay thế cho Cột B.
xlUp là duyệt từ dưới lên tìm thấy dữ liệu trả về vị trí
xlLeft là duyệt từ phải qua trái. không phải là thay xlLeft cho xlUp của code trên đâu.
- .Range("B" & Rows.Count).End(xlUp).Row - chỗ này là dựa vào cột B để duyệt hàng cuối chứa dữ liệu từ dưới lên
Các cột dữ liệu mà trồi lên trụt xuống thì...
- thêm .Resize(UBound(arr), UBound(arr, 2)) . Cái này là mảng để in. UBound(arr) tương đương (UBound(arr, 1) là số hàng của arr, UBound(arr, 2) là số cột của arr. Bạn đổi B, C, D,.. Hàm này nó sẽ tự duyệt hết mảng cho bạn

 

[be_09]

Dùng thử File này, muốn thêm bao nhiêu cột bao nhiều dòng là tùy ý.

 

[Thiện Nguyễn Minh]

- "B2:B" - đang ở cột B, muốn nhiều cột thì Đổi "B2:C", D, E,.... Nếu là cột động thì dùng (xlLeft) để trả về Address column thay thế cho Cột B.
xlUp là duyệt từ dưới lên tìm thấy dữ liệu trả về vị trí
xlLeft là duyệt từ phải qua trái. không phải là thay xlLeft cho xlUp của code trên đâu.
- .Range("B" & Rows.Count).End(xlUp).Row - chỗ này là dựa vào cột B để duyệt hàng cuối chứa dữ liệu từ dưới lên
Các cột dữ liệu mà trồi lên trụt xuống thì...
- thêm .Resize(UBound(arr), UBound(arr, 2)) . Cái này là mảng để in. UBound(arr) tương đương (UBound(arr, 1) là số hàng của arr, UBound(arr, 2) là số cột của arr. Bạn đổi B, C, D,.. Hàm này nó sẽ tự duyệt hết mảng cho bạn

Mình cũng thử thay đổi như bạn nói nhưng có lẽ VBA của mình chưa đủ để làm được, nếu được thì bạn code giúp mình để copy từ B:E hay H,K gì cũng đc về mình edit lại nhé. Làm phiền bạn

Bài đã được tự động gộp: 24/10/18

Dùng thử File này, muốn thêm bao nhiêu cột bao nhiều dòng là tùy ý.

Mình đã xem file của bạn nhưng chưa add được macro vào file mình cho chạy đc.

 

[giaiphap]

Mình cũng thử thay đổi như bạn nói nhưng có lẽ VBA của mình chưa đủ để làm được, nếu được thì bạn code giúp mình để copy từ B:E hay H,K gì cũng đc về mình edit lại nhé. Làm phiền bạn

Bài đã được tự động gộp: 24/10/18

Mình đã xem file của bạn nhưng chưa add được macro vào file mình cho chạy đc.

Tôi thấy code #2 đã đáp ứng được yêu cầu của bạn rồi mà.

 

[Thiện Nguyễn Minh]

Hi all,
Mục đích mình muốn copy để save vùng lớn hơn thay vì chỉ một cột là vì tôi muôn save luôn dữ liệu thời gian.
Tôi có tham khảo đoạn code sau thấy ok nhưng nó lại đụng với macro "save" ở trên, các bạn xem giúp tôi phải fix như thế nào nhé!
Code save:

Sub savetocopydata()
    Dim arr
    ThisWorkbook.Save

    If ThisWorkbook.Saved Then _
        arr = Sheets("sheet1").Range("B9:B" & Sheets("sheet1").Range("B" & Rows.count).End(xlUp).Row): _
        Sheets("save").Range("B" & Rows.count).End(xlUp).Offset(1).Resize(UBound(arr)) = arr
End Sub

Đây là code chèn ngày tháng tự động:

Private Sub worksheet_change(ByVal target As Range)
Dim workrng As Range
Dim rng As Range

Dim xoffsetcolumn As Integer
Set workrng = Intersect(Application.ActiveSheet.Range("B:B"), target)
xoffsetcolumn = 1
If Not workrng Is Nothing Then
Application.EnableEvents = False
For Each rng In workrng
If Not VBA.IsEmpty(rng.Value) Then
rng.Offset(0, xoffsetcolumn).Value = Now
rng.Offset(o, xoffsetcolumn).NumberFormat = "dd-mm-yyyy,hh:mm:ss"
Else
rng.Offset(0, xoffsetcolumn).ClearContents
End If
Next
Application.EnableEvents = True
End If

End Sub

và tôi bị báo lỗi dòng này:
Set workrng = Intersect(Application.ActiveSheet.Range("B:B"), target)

 

[HeSanbi]

Mình cũng thử thay đổi như bạn nói nhưng có lẽ VBA của mình chưa đủ để làm được, nếu được thì bạn code giúp mình để copy từ B:E hay H,K gì cũng đc về mình edit lại nhé. Làm phiền bạn

Mọi người giúp đỡ bạn nhiệt tình mà không tải file về test.
- copyAllDataMotion: hàm này truy lùng hết bảng tính khi gặp dữ liệu, đừng để dữ liệu lung tung
copyAllDataMotion(Sheets("sheet1").Range("B9"), Sheets("save").Range("B2"))
nếu copyAllDataMotion(Sheets("sheet1").Range("B9")) thì nó trả về 1 mảng, đặt vào đâu tùy bạn

- copyAllDataStatic: thay chữ B thành chữ E thôi mà cũng phải đăng 1 bài viết hỏi

Function copyAllDataMotion(fromRng As Range, Optional toRng As Range) As Variant
        If IsArray(fromRng) Then MsgBox "fromRng not received Array": Exit Function
        Dim arr, lastRow As Long, lastCol As Long
        lastCol = Znew.Cells(fromRng.Row, Columns.Count).End(xlToLeft).Column
        lastRow = Znew.Range("O" & Rows.Count).End(xlUp).Row
        arr = Znew.Range(Cells(fromRng.Row, fromRng.Column), Cells(lastRow, lastCol)).Value
        If Not toRng Is Nothing Then
            Worksheets(toRng.Parent.Name).Cells(Rows.Count, toRng.Column).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr, 2)) = arr
        End If
        copyAllDataMotion = arr
    End Function

    Sub copyAllDataStatic()
        Dim arr
        arr = Sheets("sheet1").Range("B9:E" & Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row)
        Sheets("save").Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr , 2)) = arr
    End Sub

 

[Thiện Nguyễn Minh]

Nếu thử đc thì mình ko hỏi bạn à.
Mình nhận sự giúp đỡ của bạn nhưng xin phép ko nhận thái độ của bạn.