Lấy giữ liệu từ sheet1 qua sheet2 theo điều kiện (1 người xem)

lhthai · 4/2/15

Hiện tại mình có đoạn code lấy giữ liệu từ sheet1 qua sheet2 sau
Nay muốn lấy giữ liệu giống cột H:L (xem file dính kèm)

Mã:

Private Sub CommandButton21_Click()
Dim Arr(), Darr(1 To 5000, 1 To 5), I, J, K
Arr = Range("B11", [B5000].End(xlUp)).Resize(, 21).Value
For I = 1 To UBound(Arr, 1)
       K = K + 1
For J = 1 To 5
       Darr(K, 1) = Arr(I, 5)
       Darr(K, 2) = Arr(I, 6)
       Darr(K, 3) = Arr(I, 7)
       Darr(K, 4) = Arr(I, 8)
       Darr(K, 5) = Arr(I, 10)
       Next
       Next
       Sheet2.Range("B4:F5000").ClearContents
       Sheet2.Range("B4").Resize(K, 5) = Darr
End Sub

chuot0106 · 4/2/15

lhthai đã viết:
Hiện tại mình có đoạn code lấy giữ liệu từ sheet1 qua sheet2 sau
Nay muốn lấy giữ liệu giống cột H:L (xem file dính kèm)

Mã:

Private Sub CommandButton21_Click() Dim Arr(), Darr(1 To 5000, 1 To 5), I, J, K Arr = Range("B11", [B5000].End(xlUp)).Resize(, 21).Value For I = 1 To UBound(Arr, 1) K = K + 1 For J = 1 To 5 Darr(K, 1) = Arr(I, 5) Darr(K, 2) = Arr(I, 6) Darr(K, 3) = Arr(I, 7) Darr(K, 4) = Arr(I, 8) Darr(K, 5) = Arr(I, 10) Next Next Sheet2.Range("B4:F5000").ClearContents Sheet2.Range("B4").Resize(K, 5) = Darr End Sub

Đoạn code này là của bạn hay của ai? Nếu là của bạn mình nghĩ chắc bạn tự sửa được chứ?

Kiều Mạnh · 4/2/15

lhthai đã viết:
Hiện tại mình có đoạn code lấy giữ liệu từ sheet1 qua sheet2 sau
Nay muốn lấy giữ liệu giống cột H:L (xem file dính kèm)

Mã:

Private Sub CommandButton21_Click() Dim Arr(), Darr(1 To 5000, 1 To 5), I, J, K Arr = Range("B11", [B5000].End(xlUp)).Resize(, 21).Value For I = 1 To UBound(Arr, 1) K = K + 1 For J = 1 To 5 Darr(K, 1) = Arr(I, 5) Darr(K, 2) = Arr(I, 6) Darr(K, 3) = Arr(I, 7) Darr(K, 4) = Arr(I, 8) Darr(K, 5) = Arr(I, 10) Next Next Sheet2.Range("B4:F5000").ClearContents Sheet2.Range("B4").Resize(K, 5) = Darr End Sub

Thử code sau xem thế nào

PHP:

Sub CopyNguon()
Dim nguon(), kq(), i As Long, j As Long, k As Long
nguon = Range([B4], [B1000].End(3)).Resize(, 5).Value
ReDim kq(1 To UBound(nguon, 1), 1 To UBound(nguon, 2))
For i = 1 To UBound(nguon, 1)
    If nguon(i, 1) <> "" Then
        k = k + 1
        For j = 1 To UBound(nguon, 2)
            kq(k, j) = nguon(i, j)
        Next
    End If
Next
Range("N4").Resize(UBound(nguon, 1), 5) = kq
End Sub

lhthai · 4/2/15

chuot0106 đã viết:
Đoạn code này là của bạn hay của ai? Nếu là của bạn mình nghĩ chắc bạn tự sửa được chứ?

Mình học hỏi từ diễn đàn thôi
mình thêm điều kiện Arr(I, 1) > 0 thì bỏ được khoảng trắng thôi còn giá trị Arr(I, 10) không biết làm cách nào
Bạn gửi ý cho mình để tìm hiểu thêm

Mã:

If Arr(I, 1) > 0 Then
       K = K + 1
For J = 1 To 5
       Darr(K, 1) = Arr(I, 5)
       Darr(K, 2) = Arr(I, 6)
       Darr(K, 3) = Arr(I, 7)
       Darr(K, 4) = Arr(I, 8)
[COLOR=#ff0000]       Darr(K, 5) = Arr(I, 10) [/COLOR]


       Next
       End If
       Next

giangleloi · 4/2/15

lhthai đã viết:
Mình học hỏi từ diễn đàn thôi
mình thêm điều kiện Arr(I, 1) > 0 thì bỏ được khoảng trắng thôi còn giá trị Arr(I, 10) không biết làm cách nào
Bạn gửi ý cho mình để tìm hiểu thêm

Mã:

If Arr(I, 1) > 0 Then K = K + 1 For J = 1 To 5 Darr(K, 1) = Arr(I, 5) Darr(K, 2) = Arr(I, 6) Darr(K, 3) = Arr(I, 7) Darr(K, 4) = Arr(I, 8) [COLOR=#ff0000] Darr(K, 5) = Arr(I, 10) [/COLOR] Next End If Next

Mình sửa mò theo code của bạn

Private Sub CommandButton21_Click()Dim Arr(), Darr(1 To 5000, 1 To 5), I, J, K, G
Application.ScreenUpdating = False
Arr = Range("B11", [B5000].End(xlUp)).Resize(, 21).Value
For I = 1 To UBound(Arr, 1)
K = K + 1
For J = 1 To 5
Darr(K, 1) = Arr(I, 5)
Darr(K, 2) = Arr(I, 6)
Darr(K, 3) = Arr(I, 7)
Darr(K, 4) = Arr(I, 8)
Darr(K + 1, 5) = Arr(I, 10)
Next
Next
Sheet2.Range("B4:F5000").ClearContents
Sheet2.Range("B4").Resize(K, 5) = Darr
With Sheet2.UsedRange
For G = .Rows.Count To 1 Step -1
If WorksheetFunction.CountA(.Cells(G, 1).EntireRow) = 0 Then
.Cells(G, 1).EntireRow.Delete
End If
Next G
End With
Application.ScreenUpdating = True
End Sub

Kiều Mạnh · 4/2/15

SORRY hồi nảy code lộn sửa lại một tẹo
thử lại nha

PHP:

Sub CopyNguon()
Dim nguon(), kq(), i As Long, j As Long, k As Long
nguon = Range([F11], [F1000].End(3)).Resize(, 6).Value
ReDim kq(1 To UBound(nguon, 1), 1 To UBound(nguon, 2))
For i = 1 To UBound(nguon, 1)
    If nguon(i, 1) <> "" Then
        k = k + 1
        For j = 1 To UBound(nguon, 2)
            kq(k, j) = nguon(i, j)
        Next
    End If
Next
Sheet2.Range("N4").Resize(UBound(nguon, 1), 5) = kq
End Sub

lhthai · 4/2/15

kieu manh đã viết:

SORRY hồi nảy code lộn sửa lại một tẹo
thử lại nha

PHP:

Sub CopyNguon()
Dim nguon(), kq(), i As Long, j As Long, k As Long
nguon = Range([F11], [F1000].End(3)).Resize(, 6).Value
ReDim kq(1 To UBound(nguon, 1), 1 To UBound(nguon, 2))
For i = 1 To UBound(nguon, 1)
    If nguon(i, 1) <> "" Then
        k = k + 1
        For j = 1 To UBound(nguon, 2)
            kq(k, j) = nguon(i, j)
        Next
    End If
Next
Sheet2.Range("N4").Resize(UBound(nguon, 1), 5) = kq
End Sub

Cám ơn bạn nha
Nhưng kết quả phần kq(k, 5) chưa đúng

Kiều Mạnh · 4/2/15

thì sửa lại thành kq(k, 6)

Ba Tê · 4/2/15

lhthai đã viết:
Mình học hỏi từ diễn đàn thôi
mình thêm điều kiện Arr(I, 1) > 0 thì bỏ được khoảng trắng thôi còn giá trị Arr(I, 10) không biết làm cách nào
Bạn gửi ý cho mình để tìm hiểu thêm

Mã:

If Arr(I, 1) > 0 Then K = K + 1 For J = 1 To 5 Darr(K, 1) = Arr(I, 5) Darr(K, 2) = Arr(I, 6) Darr(K, 3) = Arr(I, 7) Darr(K, 4) = Arr(I, 8) [COLOR=#ff0000] Darr(K, 5) = Arr(I, 10) [/COLOR] Next End If Next

Chắc là muốn như vầy:

PHP:

Private Sub CommandButton1_Click()
Dim sArr(), dArr(1 To 5000, 1 To 5), I As Long, J As Long, K As Long, Tem As String
sArr = Range("F11", [F65536].End(xlUp)).Resize(, 6).Value
For I = 1 To UBound(sArr, 1)
    If sArr(I, 6) <> Empty Then Tem = sArr(I, 6)
    If sArr(I, 1) <> Empty Then
        K = K + 1
        For J = 1 To 4
            dArr(K, J) = sArr(I, J)
        Next J
        dArr(K, 5) = Tem
    End If
Next I
With Sheet2
    .Range("B4:F5000").ClearContents
    .Range("B4").Resize(K, 5) = dArr
End With
End Sub

lhthai · 4/2/15

Ba Tê đã viết:

Chắc là muốn như vầy:

PHP:

Private Sub CommandButton1_Click()
Dim sArr(), dArr(1 To 5000, 1 To 5), I As Long, J As Long, K As Long, Tem As String
sArr = Range("F11", [F65536].End(xlUp)).Resize(, 6).Value
For I = 1 To UBound(sArr, 1)
    If sArr(I, 6) <> Empty Then Tem = sArr(I, 6)
    If sArr(I, 1) <> Empty Then
        K = K + 1
        For J = 1 To 4
            dArr(K, J) = sArr(I, J)
        Next J
        dArr(K, 5) = Tem
    End If
Next I
With Sheet2
    .Range("B4:F5000").ClearContents
    .Range("B4").Resize(K, 5) = dArr
End With
End Sub

Rất đúng ý mình
Cám ơn anh Ba Tê nhiều

Lấy giữ liệu từ sheet1 qua sheet2 theo điều kiện (1 người xem)

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

lhthai

Thành viên thường trực

chuot0106

Thành viên gắn bó

Kiều Mạnh

I don't program, I beat code into submission!!!

lhthai

Thành viên thường trực

giangleloi

Thành viên gắn bó

Kiều Mạnh

I don't program, I beat code into submission!!!

lhthai

Thành viên thường trực

Kiều Mạnh

I don't program, I beat code into submission!!!

Ba Tê

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

lhthai

Thành viên thường trực

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

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.