Giúp code copy dữ liệu từ nhiều dòng sang 2 cột, lọc bỏ dữ liệu trống (1 người xem)

huynhphi2017 · 1/4/19

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 đỡ !

snow25 · 1/4/19

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 đỡ !

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

huynhphi2017 · 1/4/19

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 !

snow25 · 1/4/19

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 !

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é.

.

HieuCD · 1/4/19

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 đỡ !

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

SA_DQ · 1/4/19

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

huynhphi2017 · 1/4/19

snow25 đã viết:
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é..

Bạn snow25,

Tôi đọc nhầm số dòng, dòng đó là 145 bạn à.

snow25 · 1/4/19

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

Cả 1 đoạn dài thế này mà xác định mỗi cái C.

.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

huynhphi2017 · 1/4/19

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

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 !

SA_DQ · 1/4/19

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.

snow25 · 1/4/19

SA_DQ đã viết:
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.

Cái này cháu thấy hình như là lấy từ phần mềm ra chứ làm gì có kiểu nhập liệu này.

Ba Tê · 1/4/19

huynhphi2017 đã viết:
Bạn snow25,

Tôi đọc nhầm số dòng, dòng đó là 145 bạn à.

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

HieuCD · 1/4/19

snow25 đã viết:
Cả 1 đoạn dài thế này mà xác định mỗi cái C..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

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 !

Kiểm tra rồi, kết quả có lấy các tô đỏ

huynhphi2017 · 1/4/19

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

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.

Giúp code copy dữ liệu từ nhiều dòng sang 2 cột, lọc bỏ dữ liệu trống (1 người xem)

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

huynhphi2017

Thành viên mới

File đính kèm

snow25

Thành viên gạo cội

huynhphi2017

Thành viên mới

snow25

Thành viên gạo cội

HieuCD

Chuyên gia GPE

SA_DQ

/(hông là gì!

huynhphi2017

Thành viên mới

File đính kèm

snow25

Thành viên gạo cội

huynhphi2017

Thành viên mới

File đính kèm

SA_DQ

/(hông là gì!

snow25

Thành viên gạo cội

Ba Tê

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

HieuCD

Chuyên gia GPE

huynhphi2017

Thành viên mới

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

Đếm ngược thời gian