Lấy dữ liệu và nhân đôi từng dòng (1 người xem)

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

loinguyen212

Thành viên thường trực
Tham gia
21/2/14
Bài viết
254
Được thích
35
Em chào anh chị.
Em muốn copy được dữ liệu từ sheet1 sang sheet2 với điều kiện là mỗi dòng thì copy thêm 1 dòng. Nhờ mọi người giúp em.
 

File đính kèm

Em chào anh chị.
Em muốn copy được dữ liệu từ sheet1 sang sheet2 với điều kiện là mỗi dòng thì copy thêm 1 dòng. Nhờ mọi người giúp em.
Thử cái này xem sao
Mã:
Private Sub CommandButton1_Click()
Dim Arr(), Darr(1 To 65536, 1 To 3), I, J, K
Arr = Range("C8", [C56536].End(xlUp)).Resize(, 3)
For I = 1 To UBound(Arr, 1)
      For J = 1 To 2 
            K = K + 1
            Darr(K, 1) = Arr(I, 1)
            Darr(K, 2) = Arr(I, 2)
            Darr(K, 3) = Arr(I, 3)
            Next
            Next
            Sheet2.Range("C8:E2000").ClearContents
            Sheet2.Range("C8").Resize(K, 3) = Darr
End Sub
 
Upvote 0
Cảm ơn bác lhthai, em đang đọc và làm việc thử xem nó đã phù hợp hẳn chưa. Cảm ơn bác nhiều vì đã chia sẻ. Chúc thành công!
 
Upvote 0
Cảm ơn bác lhthai, em đang đọc và làm việc thử xem nó đã phù hợp hẳn chưa. Cảm ơn bác nhiều vì đã chia sẻ. Chúc thành công!
PHP:
Private Sub CommandButton1_Click()
Dim Arr(), Darr(1 To 65536, 1 To 3), I, J, K
Arr = Range("C8", [C56536].End(xlUp)).Resize(, 3)
For I = 1 To UBound(Arr, 1)
      For J = 1 To 2 
            K = K + 1
            Darr(K, 1) = Arr(I, 1)
            Darr(K, 2) = Arr(I, 2)
            Darr(K, 3) = Arr(I, 3)
            Next
            Next
            Sheet2.Range("C8:E2000").ClearContents
            Sheet2.Range("C8").Resize(K, 3) = Darr
End Sub
Đoạn này chắc chắn ko đúng vì copy một lần thôi. lhthai nên testcẩn thận trước khi gửi bài lên cho chủ thớt nhé
 
Upvote 0
Em chào anh chị.
Em muốn copy được dữ liệu từ sheet1 sang sheet2 với điều kiện là mỗi dòng thì copy thêm 1 dòng. Nhờ mọi người giúp em.
Bạn thử cả cái này xem OK không
Mã:
Private Sub CommandButton21_Click()
Dim Arr(), dark(1 To 5000, 1 To 3), i As Long, j As Long, k As Long
Arr = Range("C8", [C65536].End(xlUp)).Resize(, 3).Value
For i = 1 To UBound(Arr, 1)
  If Arr(i, 1) <> Empty Then
     k = 2 * k + 1
     For j = 1 To 3
       dark(2 * i - 1, j) = Arr(i, j)
       dark(2 * i, j) = Arr(i, j)
     Next j
  End If
Next i
With Sheet2
   .Range("B4:D5000").ClearContents
   .Range("B4").Resize(k, 3) = dark
End With
End Sub
 
Upvote 0
Em chào anh chị.
Em muốn copy được dữ liệu từ sheet1 sang sheet2 với điều kiện là mỗi dòng thì copy thêm 1 dòng. Nhờ mọi người giúp em.
Thử 1 vòng lặp xem sao
Mã:
Public Sub Nhan_Ban()
Dim DL, kq(), r As Long
DL = Sheet1.UsedRange
ReDim kq(1 To UBound(DL) * 2, 1 To 3)

For r = 1 To UBound(kq)
kq(r, 1) = DL(Int((r - 1) / 2) + 1, 1)
kq(r, 2) = DL(Int((r - 1) / 2) + 1, 2)
kq(r, 3) = DL(Int((r - 1) / 2) + 1, 3)
Next r

Sheet2.UsedRange.Clear
Sheet2.Range("A1").Resize(UBound(kq), 3).Value = kq
Sheet2.Range("C1", Sheet2.Range("C1").End(xlDown)).NumberFormat = "dd/mm/yyy"
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
PHP:
Private Sub CommandButton1_Click()
Dim Arr(), Darr(1 To 65536, 1 To 3), I, J, K
Arr = Range("C8", [C56536].End(xlUp)).Resize(, 3)
For I = 1 To UBound(Arr, 1)
      For J = 1 To 2 
            K = K + 1
            Darr(K, 1) = Arr(I, 1)
            Darr(K, 2) = Arr(I, 2)
            Darr(K, 3) = Arr(I, 3)
            Next
            Next
            Sheet2.Range("C8:E2000").ClearContents
            Sheet2.Range("C8").Resize(K, 3) = Darr
End Sub
Đoạn này chắc chắn ko đúng vì copy một lần thôi. lhthai nên testcẩn thận trước khi gửi bài lên cho chủ thớt nhé
Không biết đoạn code mình sai chỗ nào nhờ bạn chỉ dẫn thêm
 
Upvote 0
Đoạn của bạn có sai đâu. Có sai là sai ở người nhầm lẫn vấn đề mà luôn dùng từ "Chắc chắn".
Bạn đã test chưa, ban nói như vậy, code nhìn qua là biết chỉ có thể copy một lần làm sao đúng yêu câu của tác giả được, chưa test code của một bạn ở trên nữa, còn của của anh Hùng mới đúng yêu cầu. Tại sao tôi nói chắc chắn vì code này trước Tôi, thầy ba tê và anh Quang Hải làm bài cho lhthai nên tôi mới nói nên test cẩn thận trước khi gửi bai là vì vậy
 
Lần chỉnh sửa cuối:
Upvote 0
Không biết đoạn code mình sai chỗ nào nhờ bạn chỉ dẫn thêm
Private Sub CommandButton2_Click()


Dim Arr(), Darr(1 To 65536, 1 To 3), I, J, K
With Sheet1
Arr = .Range(.[C8], .[C56536].End(xlUp)).Resize(, 3).Value2
End With
For I = 1 To UBound(Arr, 1)

K = K + 1
Darr(K, 1) = Arr(I, 1)
Darr(K, 2) = Arr(I, 2)
Darr(K, 3) = Arr(I, 3)
Next

Sheet2.Range("C8:E2000").ClearContents
Sheet2.Range("C8").Resize(K, 3).Value = Darr




End Sub
Bạn có thể sửa như này nhưng ko đúng yều tác giả, vì copy được 1 lần, tác giả yêu cầu thêm 1 lần copy nữa mà
 
Upvote 0
Bạn đã test chưa, ban nói như vậy, code nhìn qua là biết chỉ có thể copy một lần làm sao đúng yêu câu của tác giả được, chưa test code của một bạn ở trên nữa, còn của của anh Hùng mới đúng yêu cầu. Tại sao tôi nói chắc chắn vì code này trước Tôi, thầy ba tê và anh Quang Hải làm bài cho lhthai nên tôi mới nói nên test cẩn thận trước khi gửi bai là vì vậy

Xin bạn hãy xem kỹ lại bài của bạn ấy. Và nếu nhìn không rõ thì hãy test đi. Bạn áp đặt như vậy quy ra là những người đi hỏi bài thì mãi mãi không làm được bài hay sao?
 
Upvote 0
Xin bạn hãy xem kỹ lại bài của bạn ấy. Và nếu nhìn không rõ thì hãy test đi. Bạn áp đặt như vậy quy ra là những người đi hỏi bài thì mãi mãi không làm được bài hay sao?
Ok, xin lỗi bạn lhthai, nhưng tôi ko thích cách quy chụp và phản hồi của bạn, bài trước tôi và bạn có tranh luận về biểu đồ Gant, tôi đã nói là tranh luận, sai là điều bình thường và tôi sẽ xin lỗi đoàng hoàng , đừng có kiểu quy chụp như thế, xong topic nào là thôi, đùng có để bụng thế
 
Upvote 0
Thử cái này xem sao
Mã:
Private Sub CommandButton1_Click()
Dim Arr(), Darr(1 To 65536, 1 To 3), I, J, K
Arr = Range("C8", [C56536].End(xlUp)).Resize(, 3)
For I = 1 To UBound(Arr, 1)
      For J = 1 To 2 
            K = K + 1
            Darr(K, 1) = Arr(I, 1)
            Darr(K, 2) = Arr(I, 2)
            Darr(K, 3) = Arr(I, 3)
            Next
            Next
            Sheet2.Range("C8:E2000").ClearContents
            Sheet2.Range("C8").Resize(K, 3) = Darr
End Sub
Không biết máy tôi có vấn đề gì ko, nhưng test của bạn nó không nhân
PHP:
Sub copy2()
Dim Arr(), Darr(1 To 65536, 1 To 3), I, J, K
With Sheet1
    Arr = .Range(.[C8], .[C56536].End(xlUp)).Resize(, 3)
End With


For I = 1 To UBound(Arr, 1)
      For J = 1 To 2
            K = K + 1
            Darr(K, 1) = Arr(I, 1)
            Darr(K, 2) = Arr(I, 2)
            Darr(K, 3) = Arr(I, 3)
        Next
Next
Sheet2.Range("C8:E2000").ClearContents
Sheet2.Range("C8").Resize(K, 3) = Darr
End Sub
Mình cho vào a rr vào sheet1 thì chạy được ( như trên)
Ok được rồi, command button1 phải đặt trong sheet 1, thì arr hiểu được. Tôi đã test thành công, Xin lỗi lần nữa vì nhầm
J ở đây nó ăn theo biến k, mình test trên sub chứ ko quen command lắm, khi test trên sub arr phải thêm sheet1 thì code trên mới chạy được nên mới phản hồi vậy
 
Lần chỉnh sửa cuối:
Upvote 0
Ok, xin lỗi bạn lhthai, nhưng tôi ko thích cách quy chụp và phản hồi của bạn, bài trước tôi và bạn có tranh luận về biểu đồ Gant, tôi đã nói là tranh luận, sai là điều bình thường và tôi sẽ xin lỗi đoàng hoàng , đừng có kiểu quy chụp như thế, xong topic nào là thôi, đùng có để bụng thế

Mình không cần thiết để bụng với bạn làm gì. Chẳng được điều gì mà còn hại não. Cái quy chụp thì bạn hãy xem lại những bình luận của bạn. Xong topic nào là thôi? Mình có nhắc tới vấn đề gì. Tự bạn nhắc lại ấy chứ. Có thể cùng một câu nói nhưng làm người khác hiểu sai ý. Thôi thì cho mình xin lỗi bạn. Có gì bỏ qua hết đi nha. Làm lại từ đầu nhé :D
 
Upvote 0
Em chào anh chị.
Em muốn copy được dữ liệu từ sheet1 sang sheet2 với điều kiện là mỗi dòng thì copy thêm 1 dòng. Nhờ mọi người giúp em.
PHP:
Private Sub CommandButton1_Click()
Dim Arr(), Darr(1 To 65536, 1 To 3), i As Long, j As Long, k As Long
Arr = Range("C8", [C56536].End(xlUp)).Resize(, 3).Value2
For i = 1 To UBound(Arr, 1)
       For j = 1 To 2
            k = k + 1
            Darr(k, 1) = Arr(i, 1)
            Darr(k, 2) = Arr(i, 2)
            Darr(k, 3) = Arr(i, 3)
        Next
Next
With Sheet2
    .Range("C8:E2000").ClearContents
    .Range("C8").Resize(k, 3).Value = Darr
    .Range("E8", .Range("E8").End(xlDown)).NumberFormat = "dd/mm/yyyy"
End With
End Sub
Mình nghi nên sửa thế này thì hợp lý hơn lhthai nhé, vì cho cột E định dạng ngay tháng như bài của anh hung
 
Upvote 0
PHP:
Private Sub CommandButton1_Click()
Dim Arr(), Darr(1 To 65536, 1 To 3), i As Long, j As Long, k As Long
Arr = Range("C8", [C56536].End(xlUp)).Resize(, 3).Value2
For i = 1 To UBound(Arr, 1)
       For j = 1 To 2
            k = k + 1
            Darr(k, 1) = Arr(i, 1)
            Darr(k, 2) = Arr(i, 2)
            Darr(k, 3) = Arr(i, 3)
        Next
Next
With Sheet2
    .Range("C8:E2000").ClearContents
    .Range("C8").Resize(k, 3).Value = Darr
    .Range("E8", .Range("E8").End(xlDown)).NumberFormat = "dd/mm/yyyy"
End With
End Sub
Mình nghi nên sửa thế này thì hợp lý hơn lhthai nhé, vì cho cột E định dạng ngay tháng như bài của anh hung
Bạn cho mình hỏi thêm nha Value và Value2 khác nhau chỗ nào
 
Upvote 0
Bạn cho mình hỏi thêm nha Value và Value2 khác nhau chỗ nào
Value2 làm cho tốc độ code nhanh hơn value đó
PHP:
Sub comet()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
    .
End Sub
những đoạn như vậy đều có thể làm tăng tốc độ của code
Mình ngắt sự việc vẽ màn hình và sự kiện của excel làm code chạy nhanh hơn
 
Lần chỉnh sửa cuối:
Upvote 0
Chà, lần đầu đăng bài mà có nhiều góp ý thế này. Có nhiều thứ để ngâm cứu rồi đây, bắt đầu thôi.
 
Upvote 0
PHP:
Private Sub CommandButton1_Click()
Dim Arr(), Darr(1 To 65536, 1 To 3), i As Long, j As Long, k As Long
Arr = Range("C8", [C56536].End(xlUp)).Resize(, 3).Value2
For i = 1 To UBound(Arr, 1)
       For j = 1 To 2
            k = k + 1
            Darr(k, 1) = Arr(i, 1)
            Darr(k, 2) = Arr(i, 2)
            Darr(k, 3) = Arr(i, 3)
        Next
Next
With Sheet2
    .Range("C8:E2000").ClearContents
    .Range("C8").Resize(k, 3).Value = Darr
    .Range("E8", .Range("E8").End(xlDown)).NumberFormat = "dd/mm/yyyy"
End With
End Sub
Mình nghi nên sửa thế này thì hợp lý hơn lhthai nhé, vì cho cột E định dạng ngay tháng như bài của anh hung
Cho em hỏi ở chỗ trong vòng lặp for j... next không xuất hiện biến j nhưng máy vẫn hiểu. Em hỏi với mục đích học hỏi, mong mọi người giải đáp giúp em.
 
Upvote 0
Cho em hỏi ở chỗ trong vòng lặp for j... next không xuất hiện biến j nhưng máy vẫn hiểu. Em hỏi với mục đích học hỏi, mong mọi người giải đáp giúp em.
Mình trả lời theo ý hiểu của mình thôi nhé,
Mặc dù không có biến j nhưng j ở đây là 1 đến 2, chạy vòng lặp đầu tiên rồi vòng lặp thứ hai. Cái này chắc bạn biết thừa, nó là cái hay của vòng lặp nhẩy
 
Upvote 0
Cho em hỏi ở chỗ trong vòng lặp for j... next không xuất hiện biến j nhưng máy vẫn hiểu. Em hỏi với mục đích học hỏi, mong mọi người giải đáp giúp em.

thì mỗi lần vòng i lặp thì vòng j lặp 2 lần? bạn nói không xuất hiện biến j? là sao?
hay ý bạn là Darr(k,1) đó hả?
cứ mỗi lần vòng j lặp thì k tăng lên một lần, như vậy mỗi lần vòng i lặp k tăng lên 2
 
Upvote 0
thì mỗi lần vòng i lặp thì vòng j lặp 2 lần? bạn nói không xuất hiện biến j? là sao?
hay ý bạn là Darr(k,1) đó hả?
cứ mỗi lần vòng j lặp thì k tăng lên một lần, như vậy mỗi lần vòng i lặp k tăng lên 2
ý bạn ý là thường khai báo i thì phải có sarr(i,1) đó anh or arr(k,j)
Giải thích như anh em thấy hoàn toàn hợp lý, j ăn theo biến k
 
Upvote 0
Phía sau cột E ở sheet1 em điền thêm giá trị vào mấy cột F, G, H, I, ..(n cột nữa). Điều kiện lấy bây giờ khác một chút đấy là em chỉ lấy cột C, E, H và kể từ H đến cột n thì lấy hết (em đang giả dụ có nhiều cột để mình viết gọn lại chỗ vòng lặp for j..). Khi lấy qua sheet2 thì các cột vẫn để liền kề nhau chứ không bị tách ra (nghĩa là ở sheet1 thì cột C liền cột D, nhưng vì không lấy cột D nên sheet2 giá trị của cột E sẽ liền với cột C). Em nghĩ tình huống này sáng đến giờ mà viết code cứ bị lỗi. Mong anh chị giúp đỡ.
 
Upvote 0
Phía sau cột E ở sheet1 em điền thêm giá trị vào mấy cột F, G, H, I, ..(n cột nữa). Điều kiện lấy bây giờ khác một chút đấy là em chỉ lấy cột C, E, H và kể từ H đến cột n thì lấy hết (em đang giả dụ có nhiều cột để mình viết gọn lại chỗ vòng lặp for j..). Khi lấy qua sheet2 thì các cột vẫn để liền kề nhau chứ không bị tách ra (nghĩa là ở sheet1 thì cột C liền cột D, nhưng vì không lấy cột D nên sheet2 giá trị của cột E sẽ liền với cột C). Em nghĩ tình huống này sáng đến giờ mà viết code cứ bị lỗi. Mong anh chị giúp đỡ.
PHP:
Sub copy2()
Dim Arr(), Darr(1 To 65536, 1 To 9), I, J, K
With Sheet1
    Arr = .Range(.[C8], .[C56536].End(xlUp)).Resize(, 9)
End With
For I = 1 To UBound(Arr, 1)
      For J = 1 To 2
            K = K + 1
            Darr(K, 1) = Arr(I, 1)
            Darr(K, 2) = Arr(I, 2)
            Darr(K, 3) = Arr(I, 3)
            For l = 5 To 9
                Darr(K, l) = Arr(I, l)
            Next
        Next
Next
Sheet2.Range("C8:K2000").ClearContents
Sheet2.Range("C8").Resize(K, 9) = Darr
End Sub
bạn sửa kiểu như vậy xem, mình nghĩ là được thôi
chỗ bạn bảo cột C, D, E
thì sửa phù hợp thôi, ví dụ Darr(k,3)=arr(i,2) chẳng hạn
 
Lần chỉnh sửa cuối:
Upvote 0
Sáng nay em viết như thế này nhưng toàn bị báo lỗi, nên mới đưa lên để hỏi, bác comet xem lại giúp em với ạ.
Của em như thế này:
PHP:
            K = K + 1
            Darr(K, 1) = Arr(I, 1)
            Darr(K, 2) = Arr(I, 3)
            Darr(K, 3) = Arr(I, 6)
            For l = 4 To 9
                Darr(K, l) = Arr(I, l+ 3)

Em viết lại thế này để đúng với yêu cầu đầu bài. Bác xem giúp em với ạ.
 
Lần chỉnh sửa cuối:
Upvote 0
Sáng nay em viết như thế này nhưng toàn bị báo lỗi, nên mới đưa lên để hỏi, bác comet xem lại giúp em với ạ.
Của em như thế này:
PHP:
            K = K + 1
            Darr(K, 1) = Arr(I, 1)
            Darr(K, 2) = Arr(I, 3)
            Darr(K, 3) = Arr(I, 6)
            For l = 4 To 9
                Darr(K, l) = Arr(I, l+ 3)

Em viết lại thế này để đúng với yêu cầu đầu bài. Bác xem giúp em với ạ.
Bạn cứ hỏi thế thì khó lắm vì không có file đính kèm, bạn gửi file giả lập lên chẳng hạn thì dễ làm hơn
Liệu có phải báo lỗi out of range không vậy, darr, arr bạn nhớ mở rộng đúng vùng dòng, cột nhé, lúc khai báo biến và resize đó
 
Lần chỉnh sửa cuối:
Upvote 0
File đây ạ, những cột em bôi vàng là em muốn lấy sang sheet2, nhờ anh giúp đỡ.
 

File đính kèm

Upvote 0
Bạn cứ hỏi thế thì khó lắm vì không có file đính kèm, bạn gửi file giả lập lên chẳng hạn thì dễ làm hơn
Liệu có phải báo lỗi out of range không vậy, darr, arr bạn nhớ mở rộng đúng vùng dòng, cột nhé, lúc khai báo biến và resize đó
Em khai báo lại biến rồi, resize cũng rồi ạ.
Nó báo lỗi ở dòng Darr(K, l) = Arr(I, l+ 3) .em cũng không biết tại sao lại báo lỗi ở đây -+*/
 
Upvote 0
File đây ạ, những cột em bôi vàng là em muốn lấy sang sheet2, nhờ anh giúp đỡ.
PHP:
Sub copy2()
Dim Arr(), Darr(1 To 65536, 1 To 12), I, J, K
With Sheet1
    Arr = .Range(.[C8], .[C56536].End(xlUp)).Resize(, 12)
End With
For I = 1 To UBound(Arr, 1)
      For J = 1 To 2
            K = K + 1
            Darr(K, 1) = Arr(I, 1)
            Darr(K, 2) = Arr(I, 3)
            Darr(K, 3) = Arr(I, 6)
            For l = 4 To 9
                Darr(K, l) = Arr(I, l + 3)
            Next
        Next
Next
Sheet2.Range("C8:K2000").ClearContents
Sheet2.Range("C8").Resize(K, 12) = Darr
End Sub
ví dụ thế này thôi là cũng được mà, bạn bị báo out of range bạn mở rộng vùng darr o r arr là được mà, cả chỗ re siz e
 
Upvote 0
Em khai báo lại biến rồi, resize cũng rồi ạ.
Nó báo lỗi ở dòng Darr(K, l) = Arr(I, l+ 3) .em cũng không biết tại sao lại báo lỗi ở đây -+*/
Báo là đúng rồi từ 4 nhé thì 4+3 là 7, trong khi vùng bên darr có thêm 5 cột nữa chẳng hạn, 7+5=12 trong khi arr khai báo 11 cột. out là đương nhiên
bạn xem qua bài 30 mình test thử
 
Upvote 0
File đây ạ, những cột em bôi vàng là em muốn lấy sang sheet2, nhờ anh giúp đỡ.

Thử code này xem:
Sub copy3()
Dim Arr(), Darr(1 To 65536, 1 To 11), I, J, K
With Sheet1
Arr = .Range(.[C8], .[C56536].End(xlUp)).Resize(, 11)
End With
For I = 1 To UBound(Arr, 1)
For J = 1 To 2
K = K + 1
Darr(K, 1) = Arr(I, 1)
Darr(K, 2) = Arr(I, 3)
Darr(K, 3) = Arr(I, 6)
For l = 7 To 11
Darr(K, l - 3) = Arr(I, l)
Next
Next
Next
Sheet2.Range("C8:J2000").ClearContents
Sheet2.Range("C8").Resize(K, 8) = Darr
End Sub
 
Upvote 0
ví dụ thế này thôi là cũng được mà, bạn bị báo out of range bạn mở rộng vùng darr o r arr là được mà, cả chỗ re siz e
Cảm ơn bác, em tìm ra chỗ sai rồi, bác đã chỉ đúng lỗi nhưng em vẫn không tìm thấy, giờ thì em sửa lại được rồi. Cảm ơn bác một lần nữa, vòng lặp thật quá tuyệt, chúc bác cơm trưa ngon miệng nha.
 
Lần chỉnh sửa cuối:
Upvote 0
Cảm ơn bác, em tìm ra chỗ sai rồi, bác đã chỉ đúng lỗi nhưng em vẫn không tìm thấy, giờ thì em sửa lại được rồi. Cảm ơn bác một lần nữa, vòng lặp thật quá tuyệt, chúc bác cơm trưa ngon miệng nha.
bạn cứ xem bài 31 dân mình nghĩ sẽ thấm hơn
 
Upvote 0
Bài này mình nghĩ không cần vòng lặp nào cả. Các bạn nghĩ xem có khả thi không?
 
Upvote 0
Mượn code anh giangleloi điều chỉnh với n cột của bạn
Mã:
Private Sub CommandButton1_Click()
Dim Arr(), I, J, K, L, Col
Col = 13 'số cột n của bạn
With Sheet1
Arr = .Range(.[C8], .[C56536].End(xlUp)).Resize(, Col).Value
End With
ReDim Darr(1 To 65536, 1 To Col)
For I = 1 To UBound(Arr, 1)
           For J = 1 To 2
                 K = K + 1
                 Darr(K, 1) = Arr(I, 1)
                 Darr(K, 2) = Arr(I, 3)
                 Darr(K, 3) = Arr(I, 6)
For L = 7 To Col
                Darr(K, L - 3) = Arr(I, L)
Next
       Next
            Next
Sheet2.Range("C8:IV2000").ClearContents
Sheet2.Range("C8").Resize(K, Col) = Darr
End Sub
 
Upvote 0
Bài này mình nghĩ không cần vòng lặp nào cả. Các bạn nghĩ xem có khả thi không?
Em làm không có vòng lập thử
Mã:
Private Sub CommandButton21_Click()
Range("C8", [C56536].End(xlUp)).Resize(, 10).Copy
Sheet2.Range("C8").PasteSpecial xlPasteValues
Sheet2.Range("C56536").End(xlUp)(2).PasteSpecial xlPasteValues
Sheet2.Range("C8").CurrentRegion.Sort Key1:=Sheet2.Range("C8"), order1:=xlAscending
End Sub
 
Upvote 0
Theo mình thì bài này, không cần code, bạn làm theo các bước sau:
1. Nhân đôi Sheet1 lên, hoặc copy vùng dữ liệu đó bằng tay sang Sheet2 (tùy ý)
2. Thêm 1 cột phụ để đánh số dữ liệu từ 1 đến dòng cuối cùng chứa dữ liệu
3. Copy vùng dữ liệu cùng cột phụ, và dán vào ngay dưới vùng đó
4. Sắp xếp theo cột phụ, rồi xóa cột phụ đi.

Nếu cần code mình sẽ update bài viết sau

Mã:
Sub test()
    Dim rtc As Range, rtp As Range, iCol As Integer


    Set rtc = Sheets(1).[c8].CurrentRegion
    rtc.Copy Destination:=Sheets(2).[c8]
    
    Set rtp = Sheets(2).[c8].CurrentRegion
    
    With Sheets(2)
        .[c8].Offset(, rtp.Columns.Count).Resize(rtp.Rows.Count) _
        .FormulaR1C1 = "=row(RC[-1])"
        
        .[c8].CurrentRegion.Copy
        .[c8].Offset(rtp.Rows.Count).PasteSpecial xlPasteValues
        
        .[c8].CurrentRegion.AutoFilter
        
        iCol = .Cells(8, Columns.Count).End(xlToLeft).Column
        
        .AutoFilter.Sort.SortFields.Add Key:=.Columns(iCol) _
        , SortOn:=xlSortOnValues _
        , Order:=xlAscending _
        , DataOption:=xlSortNormal
        
        With .AutoFilter.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        .Columns(iCol).ClearContents
        .AutoFilterMode = False
    End With


End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Em chưa xem file nhưng để không dùng vòng lặp thì insert cột số thứ tự nếu chưa có, copy rồi paste 2 lần, sort theo cột STT này.
Thấy anh tham gia, em viết tiếp ý tưởng ban đầu của em nhưng em ý ko cần số thứ tự anh ah, sort theo tên luôn
PHP:
Sub copy3()
Sheet1.Range("C8", Sheet1.[C65000].End(3)).Resize(, 8).Copy
With Sheet2
    .Range("C8").PasteSpecial Paste:=xlPasteValues
    .Range("C65000").End(3).PasteSpecial Paste:=xlPasteValues
    .Range("C8").CurrentRegion.Sort Key1:=.[C8], order1:=xlAscending
End With
End Sub
 
Upvote 0
Theo mình thì bài này, không cần code, bạn làm theo các bước sau:
1. Nhân đôi Sheet1 lên, hoặc copy vùng dữ liệu đó bằng tay sang Sheet2 (tùy ý)
2. Thêm 1 cột phụ để đánh số dữ liệu từ 1 đến dòng cuối cùng chứa dữ liệu
3. Copy vùng dữ liệu cùng cột phụ, và dán vào ngay dưới vùng đó
4. Sắp xếp theo cột phụ, rồi xóa cột phụ đi.

Nếu cần code mình sẽ update bài viết sau
Em thấy anh viết code cũng hay , anh cho một bài đi anh
 
Upvote 0
Thấy anh tham gia, em viết tiếp ý tưởng ban đầu của em nhưng em ý ko cần số thứ tự anh ah, sort theo tên luôn
PHP:
Sub copy3()
Sheet1.Range("C8", Sheet1.[C65000].End(3)).Resize(, 8).Copy
With Sheet2
    .Range("C8").PasteSpecial Paste:=xlPasteValues
    .Range("C65000").End(3).PasteSpecial Paste:=xlPasteValues
    .Range("C8").CurrentRegion.Sort Key1:=.[C8], order1:=xlAscending
End With
End Sub
Thêm (2) sau end(3)
PHP:
Sub copy3()
    .Range("C65000").End(3)(2).PasteSpecial Paste:=xlPasteValues
End Sub
 
Upvote 0
Thêm (2) sau end(3)
PHP:
Sub copy3()
    .Range("C65000").End(3)(2).PasteSpecial Paste:=xlPasteValues
End Sub
thêm hay không thêm thì có ảnh hưởng gì đâu bạn, default: Row. column
Hoặc thích thì thêm thằng offset vào
.Range("C65000").End(3).Offset(1).PasteSpecial Paste:=xlPasteValues
Đây chỉ là test ý tưởng hai anh thôi, thêm off vào nữa là được
 
Lần chỉnh sửa cuối:
Upvote 0
Sáng nay em viết như thế này nhưng toàn bị báo lỗi, nên mới đưa lên để hỏi, bác comet xem lại giúp em với ạ.
Của em như thế này:
PHP:
            K = K + 1
            Darr(K, 1) = Arr(I, 1)
            Darr(K, 2) = Arr(I, 3)
            Darr(K, 3) = Arr(I, 6)
            For l = 4 To 9
                Darr(K, l) = Arr(I, l+ 3)

Em viết lại thế này để đúng với yêu cầu đầu bài. Bác xem giúp em với ạ.
Bạn cũng mới học VBA, mình biết cái gì thì chia sẻ nhé
Mình có thêm vào code đoạn bẫy lỗi sau, nó sẽ thông báo cho mình lỗi số mấy. Ở, sau đó có thể search trên mạng cách sửa lỗi dần nhá
PHP:
Sub copy2()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Dim Arr(), Darr(1 To 65536, 1 To 12), I, J, K
On Error GoTo Label
    With Sheet1
        Arr = .Range(.[C8], .[C56536].End(xlUp)).Resize(, 12).Value2
    End With
    For I = 1 To UBound(Arr, 1)
          For J = 1 To 2
                K = K + 1
                Darr(K, 1) = Arr(I, 1)
                Darr(K, 2) = Arr(I, 3)
                Darr(K, 3) = Arr(I, 6)
                For l = 4 To 9
                    Darr(K, l) = Arr(I, l + 3)
                Next
            Next
    Next
    Sheet2.Range("C8:K2000").ClearContents
    Sheet2.Range("C8").Resize(K, 12).Value = Darr
Label:
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
If Err <> 0 Then
    MsgBox Err.Number & ":" & Err.Description, vbCritical, "Loi roi ban oi"
End If
End Sub
 
Upvote 0
thêm hay không thêm thì có ảnh hưởng gì đâu bạn, default: Row. column
Hoặc thích thì thêm thằng offset vào
.Range("C65000").End(3).Offset(1).PasteSpecial Paste:=xlPasteValues
Đây chỉ là test ý tưởng hai anh thôi, thêm off vào nữa là được
Bạn nói thêm (2) hay thêm (2) sau end không ảnh hưởng
Mình thấy nếu thiếu (2) kết quả mất 1 dòng dữ liệu
Bạn chỉ mượn code của bạn trên chỉnh sữa lại thôi.
 
Upvote 0
Bạn nói thêm (2) hay thêm (2) sau end không ảnh hưởng
Mình thấy nếu thiếu (2) kết quả mất 1 dòng dữ liệu
Bạn chỉ mượn code của bạn trên chỉnh sữa lại thôi.
Đúng là mất 1 dòng, chỉ có phần currenregion là mượn của lhthai thôi, những bài trước đây mình viết đều có offset cả. ví dụ thế này chẳng han, vì như mình đã nói từ đâu ý tưởng lúc đầu là định viết thế này rồi
PHP:
Sub copy()
Sheets("PLHD").Range("A10:G5000").ClearContents

Sheets("KL").Range("A13", Sheets("KL").[A65000].End(3)).Resize(, 7).copy
Sheets("PLHD").Range("A65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End Sub
 
Upvote 0
Hơn nữa, currengregion mình đã từng đọc của Thầy SA_DQ rồi nên mình nghĩ cũng không vấn đề gì lắm. có bài tiếng anh của Thầy dịch, nó cũng là tính năng trong Ctrl+G thôi
Chia sẻ luôn là khi lhthai viết đã định ko viết tiếp nữa vì không cần thiết nhưng anh Hậu và mình có quen biết ngoài đời thấy ý tưởng của anh và anh Quang hải nên lại nhảy vào thhooi, curren này anh Hải cũng hay dùng lắm
Thân
 
Lần chỉnh sửa cuối:
Upvote 0
Hơn nữa, currengregion mình đã từng đọc của Thầy SA_DQ rồi nên mình nghĩ cũng không vấn đề gì lắm. có bài tiếng anh của Thầy dịch, nó cũng là tính năng trong Ctrl+G thôi
Chia sẻ luôn là khi lhthai viết đã định ko viết tiếp nữa vì không cần thiết nhưng anh Hậu và mình có quen biết ngoài đời thấy ý tưởng của anh và anh Quang hải nên lại nhảy vào thhooi, curren này anh Hải cũng hay dùng lắm
Thân
Học hỏi thêm được currengregion là Ctrl+G
Sẵn đây hỏi thêm luôn (2) sau end là gi
 
Upvote 0
Học hỏi thêm được currengregion là Ctrl+G
Sẵn đây hỏi thêm luôn (2) sau end là gi
Mình hiểu thế này nó là chỉ số dòng từ dòng cuối cùng có dữ liệu lúc copy lần đâu, ví dụ trong bài này nó tính là E12 là 1, đến E13 là 2, chính là vùng sẽ copy lần 2, ví dụ bạn để end(3)(3) sẽ có thêm một dòng trắng ở vùng copy lần 1 và lần 2
 
Upvote 0
Học hỏi thêm được currengregion là Ctrl+G
Sẵn đây hỏi thêm luôn (2) sau end là gi
Thực ra qua bài viết này mình cảm ơn bạn nhiều là vì bạn phản hồi ko sai, vì khi viết lại chắc chắn sẽ có người phản hồi như thế. Nhưng mình ko ngại, vì miinhf có chính kiến của mình, bạn thử thay end(3)(1) càng rõ hơn, vùng 2 sẽ copy lên dòng 12 là mất dữ liệu 1 dòng như bạn nói ban đầu
 
Upvote 0
Mình hiểu thế này nó là chỉ số dòng từ dòng cuối cùng có dữ liệu lúc copy lần đâu, ví dụ trong bài này nó tính là E12 là 1, đến E13 là 2, chính là vùng sẽ copy lần 2, ví dụ bạn để end(3)(3) sẽ có thêm một dòng trắng ở vùng copy lần 1 và lần 2
Range(...).End(3) là 1 range, ví dụ E12
Range("E12") (row,col) là ô có dòng = 12+row-1, cột E . Row, Col ở đây nếu có phải >0, nếu muốn cùng hàng hay cột thì bỏ tham số row hay col đi. Nếu Range(...) chứa nhiều ô thì Range(...)(row,col) sẽ lấy ô dựa theo ô trên cùng bên trái. (Cái này khác offset)
 
Upvote 0
Em thấy anh viết code cũng hay , anh cho một bài đi anh

Đây, không biết có hay hay không.

Mã:
Sub test()
    Dim rtc As Range, rtp As Range, iCol As Integer


    Set rtc = Sheets(1).[c8].CurrentRegion
    rtc.Copy Destination:=Sheets(2).[c8]
    
    Set rtp = Sheets(2).[c8].CurrentRegion
    
    With Sheets(2)
        .[c8].Offset(, rtp.Columns.Count).Resize(rtp.Rows.Count) _
        .FormulaR1C1 = "=row(RC[-1])"
        
        .[c8].CurrentRegion.Copy
        .[c8].Offset(rtp.Rows.Count).PasteSpecial xlPasteValues
        
        .[c8].CurrentRegion.AutoFilter
        
        iCol = .Cells(8, Columns.Count).End(xlToLeft).Column
        
        .AutoFilter.Sort.SortFields.Add Key:=.Columns(iCol) _
        , SortOn:=xlSortOnValues _
        , Order:=xlAscending _
        , DataOption:=xlSortNormal
        
        With .AutoFilter.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        .Columns(iCol).ClearContents
        .AutoFilterMode = False
    End With


End Sub
 
Upvote 0
Bạn cũng mới học VBA, mình biết cái gì thì chia sẻ nhé
Mình có thêm vào code đoạn bẫy lỗi sau, nó sẽ thông báo cho mình lỗi số mấy. Ở, sau đó có thể search trên mạng cách sửa lỗi dần nhá
Ồ, kiến thức này bác chia sẻ tuyệt vời quá, cảm ơn bác Comet và rất vui được học hỏi từ mọi người.
Thân
 
Lần chỉnh sửa cuối:
Upvote 0
Thêm (2) sau end(3)
PHP:
Sub copy3()
    .Range("C65000").End(3)(2).PasteSpecial Paste:=xlPasteValues
End Sub
Cho em hỏi sau .End là (3). Vậy (3) ở đây có ý nghĩa là gì, và tại sao lại phải thêm (2) như bác nói ở trên. Em hỏi với mục đích học tập kiến thức. Thân
 
Upvote 0
Cho em hỏi sau .End là (3). Vậy (3) ở đây có ý nghĩa là gì, và tại sao lại phải thêm (2) như bác nói ở trên. Em hỏi với mục đích học tập kiến thức. Thân
Bạn xem bài 23 nhé
http://www.giaiphapexcel.com/forum/showthread.php?101307-Chia-sẻ-một-vài-kinh-nghiệm-học-VBA/page3
Ví dụ ô A1 là Nguyễn Văn A
A2 là loinguyen212
nếu bạn dùng [A65000].end(xlup) hay end(3) bạn sẽ được loinguyen212. (2) là chỉ số dòng, ko phải của end nhé . Nó tính từ loinguyen212 là 1, dòng bạn cần nhân đôi tiếp theo là dòng 2 như bài giải thích ở trên . Nếu end(3)(1) nó copy đè lên dòng E12 làm mất đi 1 dòng nên phải từ dòng 2 với công hức
12+row-1 (12+2-1 là dòng 13. Dòng copy dữ liệu mới
Bạn xem video sau về cách debug nhé
https://www.youtube.com/watch?v=ofsXteS3Pic&feature=youtu.be
https://www.youtube.com/watch?v=X1s00SVIciY&feature=youtu.be
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn xem bài 23 nhé
http://www.giaiphapexcel.com/forum/showthread.php?101307-Chia-sẻ-một-vài-kinh-nghiệm-học-VBA/page3
Ví dụ ô A1 là Nguyễn Văn A
A2 là loinguyen212
nếu bạn dùng [A65000].end(xlup) hay end(3) bạn sẽ được loinguyen212. (2) là chỉ số dòng, ko phải của end nhé . Nó tính từ loinguyen212 là 1, dòng bạn cần nhân đôi tiếp theo là dòng 2 như bài giải thích ở trên . Nếu end(3)(1) nó copy đè lên dòng E12 làm mất đi 1 dòng nên phải từ dòng 2 với công hức
12+row-1 (12+2-1 là dòng 13. Dòng copy dữ liệu mới
Cái này bác giải thích rất cặn cẽ, em đã hiểu sâu hơn được ý của Bác Hau151978 nói ở trên
"Rất tiếc video này đã bị người dùng xóa", cho em ví dụ khác đi.
 
Lần chỉnh sửa cuối:
Upvote 0
Topic này cũng dài quá rồi, có gì thì nên mở topic bạn nhé, chừng đó thôi mình nghĩ những ai mới học cũng rút được nhiều kinh nghiệm đó
 
Upvote 0
Đoạn video trên xem cũng còn rất khó hiểu ý muốn truyền đạt. Dù sao cũng rất cảm ơn bác Comet đã chia sẻ cho em nhiều điều thú vị trong lần này.
Trên đây bác QuangHai cũng có đưa ra vấn đề là không cần vòng lặp nhưng chưa có câu trả lời nào giải quyết được ý đó. Bác QuangHai cho vài lời đi ạ.
 
Upvote 0
Đoạn video trên xem cũng còn rất khó hiểu ý muốn truyền đạt. Dù sao cũng rất cảm ơn bác Comet đã chia sẻ cho em nhiều điều thú vị trong lần này.
Trên đây bác QuangHai cũng có đưa ra vấn đề là không cần vòng lặp nhưng chưa có câu trả lời nào giải quyết được ý đó. Bác QuangHai cho vài lời đi ạ.


#52 có được tính là không cần vòng lặp ko?

Mã:
Sub test()
    Dim rtc As Range, rtp As Range, iCol As Integer

    Set rtc = Sheets(1).[c8].CurrentRegion
    rtc.Copy Destination:=Sheets(2).[c8]
    
    Set rtp = Sheets(2).[c8].CurrentRegion
    
    With Sheets(2)
        .[c8].Offset(, rtp.Columns.Count).Resize(rtp.Rows.Count) _
        .FormulaR1C1 = "=row(RC[-1])"
        
        .[c8].CurrentRegion.Copy
        .[c8].Offset(rtp.Rows.Count).PasteSpecial xlPasteValues
        
        .[c8].CurrentRegion.AutoFilter
        
        iCol = .Cells(8, Columns.Count).End(xlToLeft).Column
        
        .AutoFilter.Sort.SortFields.Add Key:=.Columns(iCol) _
        , SortOn:=xlSortOnValues _
        , Order:=xlAscending _
        , DataOption:=xlSortNormal
        
        With .AutoFilter.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        .Columns(iCol).ClearContents
        .AutoFilterMode = False
    End With
End Sub
 
Upvote 0
Đoạn video trên xem cũng còn rất khó hiểu ý muốn truyền đạt. Dù sao cũng rất cảm ơn bác Comet đã chia sẻ cho em nhiều điều thú vị trong lần này.
Trên đây bác QuangHai cũng có đưa ra vấn đề là không cần vòng lặp nhưng chưa có câu trả lời nào giải quyết được ý đó. Bác QuangHai cho vài lời đi ạ.
Có bài viết không vòng lặp rồi mà.
Tham khảo thêm cách này, tuy nhiên chỉ là file giả định nên code này cũng chỉ là giả định
PHP:
Sub abc()
Dim tam As Range
   Set tam = Sheet1.Range("C8", Sheet1.[C65536].End(3))
   With Sheet2
      .[C8:J1000].ClearContents
      Union(tam, tam.Offset(, 2), tam.Offset(, 5).Resize(, 6)).Copy
      .[C8].PasteSpecial 3
      .[C65536].End(3)(2).PasteSpecial 3
      With .Range("C8", Sheet2.[C65536].End(3))
         .Resize(, 9).Sort .Parent.[C7]
      End With
   End With
End Sub
 
Upvote 0
Có bài viết không vòng lặp rồi mà.
Có bài ở trên nhưng em chưa đọc xong và hiểu hết được. Trộm nghĩ anh chắc cũng có code hay nên muốn học tập.
Tham khảo thêm cách này, tuy nhiên chỉ là file giả định nên code này cũng chỉ là giả định
PHP:
Sub abc()
Dim tam As Range
   Set tam = Sheet1.Range("C8", Sheet1.[C65536].End(3))
   With Sheet2
      .[C8:J1000].ClearContents
      Union(tam, tam.Offset(, 2), tam.Offset(, 5).Resize(, 6)).Copy
      .[C8].PasteSpecial 3
      .[C65536].End(3)(2).PasteSpecial 3
      With .Range("C8", Sheet2.[C65536].End(3))
         .Resize(, 9).Sort .Parent.[C7]
      End With
   End With
End Sub
Tuyệt vời. Bài này cho em biết thêm về Union, Cảm ơn anh rất nhiều. Chúc anh sức khỏe!
 
Lần chỉnh sửa cuối:
Upvote 0

Bài viết mới nhất

Back
Top Bottom