Giúp code copy dữ liệu từ nhiều dòng sang 2 cột, lọc bỏ dữ liệu trống

Liên hệ QC
H

huynhphi2017

Thành viên mới
Tham gia
29/11/17
Bài viết
12
Được thích
0
Giới tính
Nam
Chào các anh chị diễn đàn !

Tôi có bài toán quá khó với sức mình, đó là copy dữ liệu hơi phức tạp, nhờ các anh chị giúp đỡ.

Copy Mã lỗi và số lượng ở vùng N5:AQ304 xuống 2 cột
A157 ~ A5000 : Mã lỗi
B157 ~ B5000 : số lượng
Nếu Cột Mã lỗi không có dữ liệu thì tương ứng số lượng cũng sẽ bị xóa đi
Cuối cùng dồn và xóa các dòng trống ở A157:B5000

Tôi muốn dùng code, tạo nút lệnh thực hiện việc này.

Cảm ơn các anh chị đã quan tâm, giúp đỡ !
 

File đính kèm

  • ThongKe.xlsx
    109.7 KB · Đọc: 14
huynhphi2017 đã viết:
Chào các anh chị diễn đàn !

Tôi có bài toán quá khó với sức mình, đó là copy dữ liệu hơi phức tạp, nhờ các anh chị giúp đỡ.

Copy Mã lỗi và số lượng ở vùng N5:AQ304 xuống 2 cột
A157 ~ A5000 : Mã lỗi
B157 ~ B5000 : số lượng
Nếu Cột Mã lỗi không có dữ liệu thì tương ứng số lượng cũng sẽ bị xóa đi
Cuối cùng dồn và xóa các dòng trống ở A157:B5000

Tôi muốn dùng code, tạo nút lệnh thực hiện việc này.

Cảm ơn các anh chị đã quan tâm, giúp đỡ !
Nhấp chuột vào đây để mở rộng...
Bạn chạy thử cái sub này nhé.
Mã: 
Sub chuyendulieu()
   Dim arr, i As Long, j As Long, dic As Object, arr1, a As Long, sh As Worksheet, lr As Long
   Set dic = CreateObject("scripting.dictionary")
   For Each sh In ThisWorkbook.Worksheets
       a = 0
       arr = sh.Range("N5:Aq304").Value
       ReDim arr1(1 To UBound(arr, 1) * UBound(arr, 2) / 2, 1 To 2)
           For i = 1 To UBound(arr, 1) Step 2
               For j = 1 To UBound(arr, 2)
                   If Len(arr(i, j)) > 0 Then
                     If Not dic.exists(arr(i, j)) Then
                        a = a + 1
                        dic.Add arr(i, j), a
                        arr1(a, 1) = arr(i, j)
                        arr1(a, 2) = arr(i + 1, j)
                      Else
                         arr1(dic.Item(arr(i, j)), 2) = arr1(dic.Item(arr(i, j)), 2) + arr(i + 1, j)
                      End If
                   End If
                Next j
            Next i
            dic.RemoveAll
            lr = sh.Range("A" & Rows.Count).End(xlUp).Row
            If lr > 156 Then sh.Range("A157:B" & lr).ClearContents
            If a Then sh.Range("A157").Resize(a, 2).Value = arr1
    Next
End Sub
 
Chào bạn snow25,

Cảm ơn bạn đã giúp đỡ.

Tôi đã thử cách của bạn, kết quả là không xóa các giá trị ở dòng 164 ( dữ liệu nguồn )

Ý tôi là ở dòng 163 mà không có Mã Lỗi thì không copy nó xuống Cột A:B làm gì.

Nhờ bạn giúp đỡ tiếp dùm.

Cảm ơn rất nhiều !
 
huynhphi2017 đã viết:
Chào bạn snow25,

Cảm ơn bạn đã giúp đỡ.

Tôi đã thử cách của bạn, kết quả là không xóa các giá trị ở dòng 164 ( dữ liệu nguồn )

Ý tôi là ở dòng 163 mà không có Mã Lỗi thì không copy nó xuống Cột A:B làm gì.

Nhờ bạn giúp đỡ tiếp dùm.

Cảm ơn rất nhiều !
Nhấp chuột vào đây để mở rộng...
Bạn đưa dữ liệu thực lên nhé.Vì dòng 164 tôi có thấy gì đâu.Mà nói chi tiết ra nhé.:D.
 
huynhphi2017 đã viết:
Chào các anh chị diễn đàn !

Tôi có bài toán quá khó với sức mình, đó là copy dữ liệu hơi phức tạp, nhờ các anh chị giúp đỡ.

Copy Mã lỗi và số lượng ở vùng N5:AQ304 xuống 2 cột
A157 ~ A5000 : Mã lỗi
B157 ~ B5000 : số lượng
Nếu Cột Mã lỗi không có dữ liệu thì tương ứng số lượng cũng sẽ bị xóa đi
Cuối cùng dồn và xóa các dòng trống ở A157:B5000

Tôi muốn dùng code, tạo nút lệnh thực hiện việc này.

Cảm ơn các anh chị đã quan tâm, giúp đỡ !
Nhấp chuột vào đây để mở rộng...
Thủ với code lộn xộn nầy
Mã: 
Sub GPE()
  Dim sArr(), cArr() As Long, Res(), sh As Worksheet, Dic As Object
  Dim i As Long, j As Long, k As Long, ik As Long, eRow As Long, C As Long, tmp
  Set Dic = CreateObject("scripting.dictionary")
  For Each sh In ThisWorkbook.Worksheets
    eRow = sh.Range("N" & Rows.Count).End(xlUp).Row
    If eRow > 6 Then
      ReDim cArr(1 To eRow - 5 + 1)
      For i = 5 To eRow
        k = sh.Cells(i, 10000).End(xlToLeft).Column
        If k > 13 Then
          If j < k Then j = k
          cArr(i - 4) = k - 14 + 1
          C = C + cArr(i - 4)
        End If
      Next i
      sArr = sh.Range("N5", sh.Cells(eRow, j)).Value
      ReDim Res(1 To C, 1 To 2)
      k = 0
      For i = 1 To UBound(sArr, 1)
        tmp = sArr(i, 1)
        If Len(tmp) > 0 Then
          If IsNumeric(tmp) = False Then
            For j = 1 To cArr(i)
              tmp = sArr(i, j)
              If Len(tmp) > 0 And IsNumeric(sArr(i + 1, j)) Then
                If Not Dic.exists(tmp) Then
                  k = k + 1
                  Dic.Add tmp, k
                  Res(k, 1) = tmp
                End If
                ik = Dic.Item(tmp)
                Res(ik, 2) = Res(ik, 2) + sArr(i + 1, j)
              End If
            Next j
            i = i + 1
          End If
        End If
      Next i
    End If
    Dic.RemoveAll
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 156 Then sh.Range("A157:B" & eRow).ClearContents
    If k Then sh.Range("A157").Resize(k, 2).Value = Res
  Next
End Sub
 
Dữ liệu của bạn ở dòng 145 chưa đúng theo qui luật
PHP: 
Sub CopyDLCacDongSang2Cot()
 Dim J As Long, W As Integer, Col As Integer, Cot As Integer
 ReDim Arr(1 To 9999, 1 To 2)
 
 [A157].Resize(9999, 2).Value = Arr()
 For J = 5 To 304 Step 2
    If Cells(J, "N").Value <> "" Then
        For Cot = 14 To 99
            If Cells(J, Cot).Value = "" Then
                Exit For
            Else
                W = W + 1:
                Arr(W, 1) = Cells(J, Cot).Value
                Arr(W, 2) = Cells(J + 1, Cot).Value
            End If
        Next Cot
    End If
 Next J
 If W Then
    [A157].Resize(W, 2).Value = Arr()
 End If
End Sub
 
HieuCD đã viết:
Thủ với code lộn xộn nầy
Mã: 
Sub GPE()
  Dim sArr(), cArr() As Long, Res(), sh As Worksheet, Dic As Object
  Dim i As Long, j As Long, k As Long, ik As Long, eRow As Long, C As Long, tmp
  Set Dic = CreateObject("scripting.dictionary")
  For Each sh In ThisWorkbook.Worksheets
    eRow = sh.Range("N" & Rows.Count).End(xlUp).Row
    If eRow > 6 Then
      ReDim cArr(1 To eRow - 5 + 1)
      For i = 5 To eRow
        k = sh.Cells(i, 10000).End(xlToLeft).Column
        If k > 13 Then
          If j < k Then j = k
          cArr(i - 4) = k - 14 + 1
          C = C + cArr(i - 4)
        End If
      Next i
      sArr = sh.Range("N5", sh.Cells(eRow, j)).Value
      ReDim Res(1 To C, 1 To 2)
      k = 0
      For i = 1 To UBound(sArr, 1)
        tmp = sArr(i, 1)
        If Len(tmp) > 0 Then
          If IsNumeric(tmp) = False Then
            For j = 1 To cArr(i)
              tmp = sArr(i, j)
              If Len(tmp) > 0 And IsNumeric(sArr(i + 1, j)) Then
                If Not Dic.exists(tmp) Then
                  k = k + 1
                  Dic.Add tmp, k
                  Res(k, 1) = tmp
                End If
                ik = Dic.Item(tmp)
                Res(ik, 2) = Res(ik, 2) + sArr(i + 1, j)
              End If
            Next j
            i = i + 1
          End If
        End If
      Next i
    End If
    Dic.RemoveAll
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 156 Then sh.Range("A157:B" & eRow).ClearContents
    If k Then sh.Range("A157").Resize(k, 2).Value = Res
  Next
End Sub
Nhấp chuột vào đây để mở rộng...
Cả 1 đoạn dài thế này mà xác định mỗi cái C.:D.Em thấy hơi phí.
Mã: 
ReDim cArr(1 To eRow - 5 + 1)
      For i = 5 To eRow
        k = sh.Cells(i, 10000).End(xlToLeft).Column
        If k > 13 Then
          If j < k Then j = k
          cArr(i - 4) = k - 14 + 1
          C = C + cArr(i - 4)
        End If
      Next i
 
HieuCD đã viết:
Thủ với code lộn xộn nầy
Mã: 
Sub GPE()
  Dim sArr(), cArr() As Long, Res(), sh As Worksheet, Dic As Object
  Dim i As Long, j As Long, k As Long, ik As Long, eRow As Long, C As Long, tmp
  Set Dic = CreateObject("scripting.dictionary")
  For Each sh In ThisWorkbook.Worksheets
    eRow = sh.Range("N" & Rows.Count).End(xlUp).Row
    If eRow > 6 Then
      ReDim cArr(1 To eRow - 5 + 1)
      For i = 5 To eRow
        k = sh.Cells(i, 10000).End(xlToLeft).Column
        If k > 13 Then
          If j < k Then j = k
          cArr(i - 4) = k - 14 + 1
          C = C + cArr(i - 4)
        End If
      Next i
      sArr = sh.Range("N5", sh.Cells(eRow, j)).Value
      ReDim Res(1 To C, 1 To 2)
      k = 0
      For i = 1 To UBound(sArr, 1)
        tmp = sArr(i, 1)
        If Len(tmp) > 0 Then
          If IsNumeric(tmp) = False Then
            For j = 1 To cArr(i)
              tmp = sArr(i, j)
              If Len(tmp) > 0 And IsNumeric(sArr(i + 1, j)) Then
                If Not Dic.exists(tmp) Then
                  k = k + 1
                  Dic.Add tmp, k
                  Res(k, 1) = tmp
                End If
                ik = Dic.Item(tmp)
                Res(ik, 2) = Res(ik, 2) + sArr(i + 1, j)
              End If
            Next j
            i = i + 1
          End If
        End If
      Next i
    End If
    Dic.RemoveAll
    eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 156 Then sh.Range("A157:B" & eRow).ClearContents
    If k Then sh.Range("A157").Resize(k, 2).Value = Res
  Next
End Sub
Nhấp chuột vào đây để mở rộng...


Bạn HieuCD,

Tôi ghép thử code vào file.

Nó copy thiếu 1 số dữ liệu ( tôi tô màu đỏ )

Bạn kiểm tra giúp với nhé.

Cảm ơn bạn nhiều !
 

File đính kèm

  • ThongKe_Rev.2.xlsm
    118.6 KB · Đọc: 8
Với chủ đề tài: Dữ liệu nhập iêu cầu phải đúng qui luật.
Không ai đi làm theo cái sai của người nhập liệu.
 
huynhphi2017 đã viết:
Bạn snow25,

Tôi đọc nhầm số dòng, dòng đó là 145 bạn à.
Nhấp chuột vào đây để mở rộng...
1/ Dữ liệu của bạn (N5:AQ304) nếu đúng quy luật thì dòng lẻ là Mã lỗi, dòng chẵn (liền dưới) là số lượng. Nếu vậy dữ liệu dòng 145 là "tào lao".
2/ Hình như bạn muốn lấy tất cả các Mã lỗi có số lượng mà không cộng dồn nếu trùng mã lỗi? Nếu vậy thì các code dùng Dic là "phí của".
Nếu 1/ và 2/ đều đúng thì code như vầy:
PHP: 
Public Sub Gpe2()
Dim sArr(), dArr()
Dim I As Long, J As Long, K As Long, Rws As Long, CoL As Long
    sArr = Range("N5:AQ304").Value
    Rws = UBound(sArr)
    CoL = UBound(sArr, 2)
ReDim dArr(1 To Rws * CoL, 1 To 2)
For I = 1 To Rws Step 2
    For J = 1 To CoL
        If sArr(I, J) <> Empty And sArr(I + 1, J) <> Empty Then
            K = K + 1
            dArr(K, 1) = sArr(I, J)
            dArr(K, 2) = sArr(I + 1, J)
        End If
    Next J
Next I
Range("A157").Resize(10000, 2).ClearContents
Range("A157").Resize(K, 2) = dArr
End Sub
 
Lần chỉnh sửa cuối:
snow25 đã viết:
Cả 1 đoạn dài thế này mà xác định mỗi cái C.:D.Em thấy hơi phí.
Mã: 
ReDim cArr(1 To eRow - 5 + 1)
      For i = 5 To eRow
        k = sh.Cells(i, 10000).End(xlToLeft).Column
        If k > 13 Then
          If j < k Then j = k
          cArr(i - 4) = k - 14 + 1
          C = C + cArr(i - 4)
        End If
      Next i
Nhấp chuột vào đây để mở rộng...
Dữ liệu không xác định bao nhiêu cột, án chừng vùng dữ liệu có thể lấy không đủ, lấy dư quá thì tốc độ sẽ chậm, thêm vài dòng lệnh để xác định dòng cột là cần thiết
huynhphi2017 đã viết:
Bạn HieuCD,

Tôi ghép thử code vào file.

Nó copy thiếu 1 số dữ liệu ( tôi tô màu đỏ )

Bạn kiểm tra giúp với nhé.

Cảm ơn bạn nhiều !
Nhấp chuột vào đây để mở rộng...
Kiểm tra rồi, kết quả có lấy các tô đỏ
 
Ba Tê đã viết:
1/ Dữ liệu của bạn (N5:AQ304) nếu đúng quy luật thì dòng lẻ là Mã lỗi, dòng chẵn (liền dưới) là số lượng. Nếu vậy dữ liệu dòng 145 là "tào lao".
2/ Hình như bạn muốn lấy tất cả các Mã lỗi có số lượng mà không cộng dồn nếu trùng mã lỗi? Nếu vậy thì các code dùng Dic là "phí của".
Nếu 1/ và 2/ đều đúng thì code như vầy:
PHP: 
Public Sub Gpe2()
Dim sArr(), dArr()
Dim I As Long, J As Long, K As Long, Rws As Long, CoL As Long
    sArr = Range("N5:AQ304").Value
    Rws = UBound(sArr)
    CoL = UBound(sArr, 2)
ReDim dArr(1 To Rws * CoL, 1 To 2)
For I = 1 To Rws Step 2
    For J = 1 To CoL
        If sArr(I, J) <> Empty And sArr(I + 1, J) <> Empty Then
            K = K + 1
            dArr(K, 1) = sArr(I, J)
            dArr(K, 2) = sArr(I + 1, J)
        End If
    Next J
Next I
Range("A157").Resize(10000, 2).ClearContents
Range("A157").Resize(K, 2) = dArr
End Sub
Nhấp chuột vào đây để mở rộng...

Dạ Bác Ba Tê,

Bác nói đúng ý , trúng phốc rồi.

Cháu đã làm theo và kết quả mỹ mãn.

Cảm ơn Bác nhiều lắm. Code hữu ích cho công việc lắm.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

H
  • Question
nhờ các bác viết mẫu cho em lệnh dùng checkbox để rút ngắn thời gian thao tác
Trả lời
15
Đọc
323
hiv174
H
kiencuong030184
  • Question
Nhờ giúp đỡ về ẩn dòng, cột có điều kiện
Trả lời
1
Đọc
37
BuiQuangThuan
B
T
V/v tối ưu xử lý đoạn code
Trả lời
1
Đọc
48
SA_DQ
SA_DQ
kiet317
Helloooooooooooo
    • Phẫn nộ
    • Buồn
Trả lời
1
Đọc
38
Hoàng Tuấn 868
H
H
  • Question
Code subtotal và tìm điều kiện
Trả lời
9
Đọc
119
Hoàng Tuấn 868
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom