Giúp sửa code thêm data vào 1 vùng lưu trử ( mới nhất nằm trên )

[hunglam123]

Chào các anh chị GPE. em có sử dụng 1 code để thêm dữ liệu từ vùng B55 sang vùng lưu trử J5:L100000 . em muốn cái nào vừa thêm mới nhất sẽ nằm trên cùng. Em có dùng code này chạy thì ok nhưng rất chậm. Nhờ mọi người sửa giúp cho nó nhanh. Em xin chân thành cảm ơn ạ !

Sub THemvaodata()
Dim sArr()
sArr = Range("J5:L1000000").Value
Range("J6").Resize(UBound(sArr), UBound(sArr, 2)) = sArr
Range("J5:L5").Value = Range("B5:D5").Value
End Sub

 

[Ba Tê]

sArr = Range("J5:L1000000").Value

Tự nhiên "chơi luôn" cả triệu dòng.
Bạn thử thay bằng:

sArr = Range("J5", Range("L1048576").End(xlUp)).Value

Khi dữ liệu lưu trữ của bạn lên đến 1 triệu dòng thì nó mới bị "Rùa".

 

[VetMini]

Code trên chỉ chép dữ liệu chứ không lý gì tới mẫu mã (kẻ viền,...)
Nếu bảng có kẻ viền thì dòng cuối cùng sẽ bị làm con rơi.

(chỉ có thế này thì mở thâu macro lên và copy/insert quách cho khoẻ)

Tự nhiên "chơi luôn" cả triệu dòng.
Bạn thử thay bằng:

sArr = Range("J5", Range("L1048576").End(xlUp)).Value

Khi dữ liệu lưu trữ của bạn lên đến 1 triệu dòng thì nó mới bị "Rùa".

Bạn đâu có cần đọc dữ liệu. Và như thế đâu có cần copy nó ra array.
set rg = Range("J5", Range("L1048576").End(xlUp))
rg.Offset(1) = rg
Trong code bài #1, thớt đã làm đúng cách copy ở dòng cuối. Nhưng không rõ tại sao lại đi lòng vòng qua array ở các dòng trên. Có lẽ do kiến thức về mảng không đủ.

 

[HeSanbi]

Code đầy đủ để thực hiện


----------------------

Sub ThemVaoData()
  On Error Goto Ends
  Dim iUp As Boolean, R, Source As Excel.Range, Target As Excel.Range, W as Excel.Worksheet
  iUp = Application.ScreenUpdating
  Application.ScreenUpdating = False
  ''---------------------------------------
  Const Rows = 1, Columns = 3, LimitRows = 10000
  Set W = ActiveSheet
  Set Source = W.Range("B5"): Set Target = W.Range("J5")
  ''---------------------------------------
  If Source.Value = "" Then Goto Ends
  With Target
    R = W.UsedRange.Rows.Count - .Row + 1
    If R > LimitRows Then R = LimitRows
    If R > 0 Then .Offset(Rows, 0).Resize(R, Columns).Value = .Resize(R, Columns).Value
    .Resize(Rows, Columns).Value = Source.Resize(Rows, Columns).Value
  End With
Ends:
  Application.ScreenUpdating = iUp
  Set Source = Nothing
  Set Target = Nothing
  Set W = Nothing
End Sub

 

[hunglam123]

Tự nhiên "chơi luôn" cả triệu dòng.
Bạn thử thay bằng:

sArr = Range("J5", Range("L1048576").End(xlUp)).Value

Khi dữ liệu lưu trữ của bạn lên đến 1 triệu dòng thì nó mới bị "Rùa".

Em cảm ơn bác nhiều. Nhưng em test kỷ thì nó sẽ sai cho 2 trường hợp sau:
- Khi Vùng lưu trữ trống chưa có dữ liệu thì code copy lần đầu tiên bị sai ( do không bắt đúng dòng cuối ngay chổ End(xlUp) )



- Khi Vùng lữu trử đầy ( Ví dụ như Vùng lưu trử J5:L20 )thì code vẫn chạy sai. ( Nếu dữ liệu đầy thì cái dưới nhất xóa đi và vẫn thêm cái mới nhất nằm trên )

Sub THemvaodata() ' dai khai Code nhu Này mà em viết dài quá không biết làm sao rút gọn

        Dim sArr(), i As Long
        i = Application.Max(Range("L20").End(xlUp).Row, 5) ' xong cuoi Va Co MAX
    
If Range("J20") = "" Then ' neu data chua Day
        sArr = Range("J5:l" & i).Value
        Range("J6").Resize(UBound(sArr), UBound(sArr, 2)) = sArr
        Range("J5:L5").Value = Range("B5:D5").Value
Else ' Neu data day rol

        sArr = Range("J5:L19").Value
        Range("J6").Resize(UBound(sArr), UBound(sArr, 2)) = sArr
        Range("J5:L5").Value = Range("B5:D5").Value
        
End If
End Sub

Nói cách minh họa dễ hiểu
kiểu giống như Lịch sử cuộc gọi gần đây Iphone nó chỉ lưu danh sách cuộc gọi gần đây nhiều nhất là 100 dòng, nếu mình gọi tiếp 1 người nữa tức là 101 người , thì nó xóa cái người cũ nhất và vẫn add cái người 101 vào dòng trên cùng

@VetMini @Ba Tê @SA_DQ @concogia xem lại giúp em

 

[VetMini]

GoTo <Cleanup> đáng lẽ phải đi sau khi các thông số lưu trữ tình trạng ban đầu đã được gán. Lúc ấy mới có đủ dữ liệu để cleanup.
Nếu error xảy ra trước lệnh save ScreenUpdating thì nát.

 

[concogia]

Với đề bài này, thử cách chèn dòng

Sub Chen()
    Range("J5:L5").Insert Shift:=xlDown
    Range("J5:L5").Value = Range("B5:D5").Value
End Sub

 

[SA_DQ]

Cũng góp vui theo hướng thầy Cò Già

Sub ThemDongDuLieuMoiLenTren()
 [K4].CurrentRegion.Offset(2).Copy Destination:=[J6]
 [J5].Resize(, 3).Value = [B5].Resize(, 3).Value
End Sub

 

[hunglam123]

Với đề bài này, thử cách chèn dòng

Sub Chen()
    Range("J5:L5").Insert Shift:=xlDown
    Range("J5:L5").Value = Range("B5:D5").Value
End Sub

Code rất hay nhưng không phù hợp với em. Ví dụ em chỉ muốn lưu trử trong khoảng J5:L20. Nếu đầy thì cái nào cũ nhất nằm dưới cùng tự xóa, vẫn thêm cái mới vào dòng trên cùng

Bài đã được tự động gộp: 22/4/20

Cũng góp vui theo hướng thầy Cò Già

Sub ThemDongDuLieuMoiLenTren()
[K4].CurrentRegion.Offset(2).Copy Destination:=[J6]
[J5].Resize(, 3).Value = [B5].Resize(, 3).Value
End Sub

cảm ơn bác nhiều
Code rất hay nhưng không phù hợp với em. Ví dụ em chỉ muốn lưu trử trong khoảng J5:L20. Nếu đầy thì cái nào cũ nhất nằm dưới cùng tự xóa, vẫn thêm cái mới vào dòng trên cùng
Nói 1 cách dể hiểu ví dụ như 1 cái ổ cứng 1TB của đầu ghi camera chẳng hạn nó lưu được 15 ngày gần đây, thì khi qua ngày 16 thì xóa cái ngày củ nhất, và vẫn thêm dữ liệu ngày 16 vào dòng trên cùng
Hoặc kiểu giống như Lịch sử cuộc gọi gần đây Iphone nó chỉ lưu danh sách cuộc gọi gần đây nhiều nhất là 100 dòng, nếu mình gọi tiếp 1 người nữa tức là 101 người , thì nó xóa cái người cũ nhất và vẫn add cái người 101 vào dòng trên cùng

 

[Phuocam]

Thử:

Sub ThemXoa1dong()
    Range("J6:L20").Value = Range("J5:L19").Value
    Range("J5:L5").Value = Range("B5:D5").Value
End Sub

 

[hunglam123]

Thử:

Sub ThemXoa1dong()
    Range("J6:L20").Value = Range("J5:L19").Value
    Range("J5:L5").Value = Range("B5:D5").Value
End Sub

cái này thì mình biết. Nhưng thí dụ 100.000 dòng là nó chậm à

 

[Lê Duy Thương]

Code rất hay nhưng không phù hợp với em. Ví dụ em chỉ muốn lưu trử trong khoảng J5:L20. Nếu đầy thì cái nào cũ nhất nằm dưới cùng tự xóa, vẫn thêm cái mới vào dòng trên cùng

Bài đã được tự động gộp: 22/4/20

cảm ơn bác nhiều
Code rất hay nhưng không phù hợp với em. Ví dụ em chỉ muốn lưu trử trong khoảng J5:L20. Nếu đầy thì cái nào cũ nhất nằm dưới cùng tự xóa, vẫn thêm cái mới vào dòng trên cùng
Nói 1 cách dể hiểu ví dụ như 1 cái ổ cứng 1TB của đầu ghi camera chẳng hạn nó lưu được 15 ngày gần đây, thì khi qua ngày 16 thì xóa cái ngày củ nhất, và vẫn thêm dữ liệu ngày 16 vào dòng trên cùng
Hoặc kiểu giống như Lịch sử cuộc gọi gần đây Iphone nó chỉ lưu danh sách cuộc gọi gần đây nhiều nhất là 100 dòng, nếu mình gọi tiếp 1 người nữa tức là 101 người , thì nó xóa cái người cũ nhất và vẫn add cái người 101 vào dòng trên cùng

BẠN THỬ MARCRO NÀY XEM

Sub ADNEWDATA()

    Sheet1.Range("J5").CurrentRegion.Offset(1).Copy Sheets("Temp").Range("A1")
    Sheet1.Range("J5").CurrentRegion.Clear
    Range("B5").CurrentRegion.Offset(1).Copy Range("J4")
    Sheets("Temp").Range("A1").CurrentRegion.Copy Sheet1.Range("J100005").End(xlUp).Offset(1)
    Application.CutCopyMode = False
    Sheets("Temp").Range("A1").CurrentRegion.Clear
    Sheet1.Range("J5").CurrentRegion.Offset(Sheet1.Range("L1") + 1).Clear
End Sub

 

[hunglam123]

Mình làm được rồi cảm ơn mọi người

Sub THemvaodata()
Dim sArr()
If Range("j5") = "" Or Range("J20") <> "" Then
        sArr = Range("J5:L19").Value
Else
        sArr = Range("J5", Range("l20").End(xlUp)).Value
End If

   Range("J6").Resize(UBound(sArr), UBound(sArr, 2)) = sArr
   Range("J5:L5").Value = Range("B5:D5").Value
End Sub

 

[hunglam123]

BẠN THỬ MARCRO NÀY XEM

Sub ADNEWDATA()

    Sheet1.Range("J5").CurrentRegion.Offset(1).Copy Sheets("Temp").Range("A1")
    Sheet1.Range("J5").CurrentRegion.Clear
    Range("B5").CurrentRegion.Offset(1).Copy Range("J4")
    Sheets("Temp").Range("A1").CurrentRegion.Copy Sheet1.Range("J100005").End(xlUp).Offset(1)
    Application.CutCopyMode = False
    Sheets("Temp").Range("A1").CurrentRegion.Clear
    Sheet1.Range("J5").CurrentRegion.Offset(Sheet1.Range("L1") + 1).Clear
End Sub

cảm ơn anh. test thấy code giật giật nên em sẽ không bao giờ áp dụng

 

[HieuCD]

Mình làm được rồi cảm ơn mọi người

Sub THemvaodata()
Dim sArr()
If Range("j5") = "" Or Range("J20") <> "" Then
        sArr = Range("J5:L19").Value
Else
        sArr = Range("J5", Range("l20").End(xlUp)).Value
End If

   Range("J6").Resize(UBound(sArr), UBound(sArr, 2)) = sArr
   Range("J5:L5").Value = Range("B5:D5").Value
End Sub

nếu Range("j5") = "" chỉ cần gán Range("J5:L5").Value = Range("B55").Value không cần sArr

 

[Nhất Chi Lan]

cảm ơn anh. test thấy code giật giật nên em sẽ không bao giờ áp dụng

Bạn thử hàm Join2DArray của Thầy NDu thử. Mình thử 13.560 dòng thấy ổn. Thích lưu lại bao nhiêu dòng thì thay lại cái N trong Code

 

[SA_DQ]

Cha chủ bài đăng này iêu cầu bài đầu khác, bài sau lại khác là sao, ta? Giống như đánh đố người khác à.
Lại trả lời người giúp mình câu trớt quớt:

cảm ơn anh. test thấy code giật giật nên em sẽ không bao giờ áp dụng

Tạm biệt!

 

[VetMini]

Cha chủ bài đăng này iêu cầu bài đầu khác, bài sau lại khác là sao, ta? Giống như đánh đố người khác à.
Lại trả lời người giúp mình câu trớt quớt:
...

Ủa bạn không biết là ở diễn đàn này chỉ có 2 người chưa bị chê cốt dỏm hay sao?

Mình cốt kiếc hàm hiếc này nọ là để trao đổi với nhau thôi. Chứ thớt thì chắc chắn là trả lời bằng một chữ "SAI" tổ bố.

 

[SA_DQ]

Ủa bạn không biết là ở diễn đàn này chỉ có 2 người chưa bị chê cốt dỏm hay sao? . . . . .

Ha, ha. . . Mình ngờ ngợ & nhớ 1 điều mà ông bà xưa hay khuyên: "Đánh chết cái nết không chừa!"