làm thế nào tách dữ liệu trong 01 ô nhiều dòng

Liên hệ QC

huonglien1901

GPE là ngôi nhà thứ 2 của tôi!!!
Tham gia
17/4/16
Bài viết
2,701
Được thích
2,433
Giới tính
Nam
Nghề nghiệp
Nhân viên kỹ thuật in ấn
Chào mọi người!

Em có vấn đề nhờ mọi người hỗ trợ.

Em muốn tách dữ liệu trong 01 ô nhiều dòng(độ dài chuỗi không cố định, có khi ngắn khi dài).

Em muôn copy dữ liệu vào ô A1 thì ô B2 tự động tách ra.( em muốn loại bỏ phần header và footer chỉ lấy phần dữ liệu)

Em có tải file PDF lên để mọi người nhìn thử. Kết quả mẫu nằm ở ô C11.

Em muốn sử dụng code+công thức cho bài toán này!

Em cảm ơn mọi người nhiều!
 

File đính kèm

  • 04602002-4.5E - SOFT YOGURT -22-01-19 -127.pdf
    1.1 MB · Đọc: 21
  • tach.xlsx
    12.8 KB · Đọc: 19
Chào mọi người!

Em có vấn đề nhờ mọi người hỗ trợ.

Em muốn tách dữ liệu trong 01 ô nhiều dòng(độ dài chuỗi không cố định, có khi ngắn khi dài).

Em muôn copy dữ liệu vào ô A1 thì ô B2 tự động tách ra.( em muốn loại bỏ phần header và footer chỉ lấy phần dữ liệu)

Em có tải file PDF lên để mọi người nhìn thử. Kết quả mẫu nằm ở ô C11.

Em muốn sử dụng code+công thức cho bài toán này!

Em cảm ơn mọi người nhiều!
Bạn xem code nhé.
Mã:
Sub tach()
Dim arr, i As Long, j As Long, a As Long, lr As Long, b As Long, T, arr1, s As String
With Sheet1
     lr = .Range("a" & Rows.Count).End(xlUp).Row
     ReDim arr(1 To lr * 50, 1 To 10)
     For i = 1 To lr
         T = Split(Chr(10) & .Cells(i, 1).Value, Chr(10))
         For j = 1 To UBound(T)
          If Len(T(j)) Then
             a = a + 1
             arr(a, 1) = T(j)
          End If
         Next j
    Next i
End With
   ReDim arr1(1 To a, 1 To 7)
   For i = 1 To a
       T = Split(" " & Trim(arr(i, 1)), " ")
       b = UBound(T)
       If b < 7 Then
          arr1(i, 1) = arr(i, 1)
       Else
           arr1(i, 1) = T(1)
           arr1(i, 2) = T(2)
           arr1(i, 3) = T(3)
           arr1(i, 7) = T(b)
           arr1(i, 6) = T(b - 1)
           arr1(i, 5) = T(b - 2)
           s = T(4)
          For j = 5 To b - 3
              s = s & " " & T(j)
          Next j
          arr1(i, 4) = s
      End If
  Next i
With Sheet2
     .Range("a1").Resize(a, 7).Value = arr1
End With
End Sub
 

File đính kèm

  • tach.xlsm
    29.4 KB · Đọc: 20
Upvote 0
Bạn xem code nhé.
Mã:
Sub tach()
Dim arr, i As Long, j As Long, a As Long, lr As Long, b As Long, T, arr1, s As String
With Sheet1
     lr = .Range("a" & Rows.Count).End(xlUp).Row
     ReDim arr(1 To lr * 50, 1 To 10)
     For i = 1 To lr
         T = Split(Chr(10) & .Cells(i, 1).Value, Chr(10))
         For j = 1 To UBound(T)
          If Len(T(j)) Then
             a = a + 1
             arr(a, 1) = T(j)
          End If
         Next j
    Next i
End With
   ReDim arr1(1 To a, 1 To 7)
   For i = 1 To a
       T = Split(" " & Trim(arr(i, 1)), " ")
       b = UBound(T)
       If b < 7 Then
          arr1(i, 1) = arr(i, 1)
       Else
           arr1(i, 1) = T(1)
           arr1(i, 2) = T(2)
           arr1(i, 3) = T(3)
           arr1(i, 7) = T(b)
           arr1(i, 6) = T(b - 1)
           arr1(i, 5) = T(b - 2)
           s = T(4)
          For j = 5 To b - 3
              s = s & " " & T(j)
          Next j
          arr1(i, 4) = s
      End If
  Next i
With Sheet2
     .Range("a1").Resize(a, 7).Value = arr1
End With
End Sub
Em cảm ơn Anh nhiều!
Anh có thể khi copy dữ liệu vào thì tự động tách ra được không Anh?
 
Upvote 0
Bạn xem code nhé.
Mã:
Sub tach()
Dim arr, i As Long, j As Long, a As Long, lr As Long, b As Long, T, arr1, s As String
With Sheet1
     lr = .Range("a" & Rows.Count).End(xlUp).Row
     ReDim arr(1 To lr * 50, 1 To 10)
     For i = 1 To lr
         T = Split(Chr(10) & .Cells(i, 1).Value, Chr(10))
         For j = 1 To UBound(T)
          If Len(T(j)) Then
             a = a + 1
             arr(a, 1) = T(j)
          End If
         Next j
    Next i
End With
   ReDim arr1(1 To a, 1 To 7)
   For i = 1 To a
       T = Split(" " & Trim(arr(i, 1)), " ")
       b = UBound(T)
       If b < 7 Then
          arr1(i, 1) = arr(i, 1)
       Else
           arr1(i, 1) = T(1)
           arr1(i, 2) = T(2)
           arr1(i, 3) = T(3)
           arr1(i, 7) = T(b)
           arr1(i, 6) = T(b - 1)
           arr1(i, 5) = T(b - 2)
           s = T(4)
          For j = 5 To b - 3
              s = s & " " & T(j)
          Next j
          arr1(i, 4) = s
      End If
  Next i
With Sheet2
     .Range("a1").Resize(a, 7).Value = arr1
End With
End Sub
Nhờ Anh hướng dẫn giúp em về sự kiện Worksheet_change được không?
Khi tác động vào cột A thì dữ liệu tự động tách ra ở sheet 2 đó Anh.
Em cảm ơn Anh nhiều
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn xem code nhé.
Mã:
Sub tach()
Dim arr, i As Long, j As Long, a As Long, lr As Long, b As Long, T, arr1, s As String
With Sheet1
     lr = .Range("a" & Rows.Count).End(xlUp).Row
     ReDim arr(1 To lr * 50, 1 To 10)
     For i = 1 To lr
         T = Split(Chr(10) & .Cells(i, 1).Value, Chr(10))
         For j = 1 To UBound(T)
          If Len(T(j)) Then
             a = a + 1
             arr(a, 1) = T(j)
          End If
         Next j
    Next i
End With
   ReDim arr1(1 To a, 1 To 7)
   For i = 1 To a
       T = Split(" " & Trim(arr(i, 1)), " ")
       b = UBound(T)
       If b < 7 Then
          arr1(i, 1) = arr(i, 1)
       Else
           arr1(i, 1) = T(1)
           arr1(i, 2) = T(2)
           arr1(i, 3) = T(3)
           arr1(i, 7) = T(b)
           arr1(i, 6) = T(b - 1)
           arr1(i, 5) = T(b - 2)
           s = T(4)
          For j = 5 To b - 3
              s = s & " " & T(j)
          Next j
          arr1(i, 4) = s
      End If
  Next i
With Sheet2
     .Range("a1").Resize(a, 7).Value = arr1
End With
End Sub
Trường hợp code Anh khi copy dữ liệu khác vào thì code không chạy đó Anh.
Bài đã được tự động gộp:

Bạn chọn phương thức worksheets change đi
Bạn có cách viết phương thức đó được không?
Cảm ơn bạn nhiều!
 
Upvote 0
Trường hợp code Anh khi copy dữ liệu khác vào thì code không chạy đó Anh.
Bài đã được tự động gộp:


Bạn có cách viết phương thức đó được không?
Cảm ơn bạn nhiều!
Đây bạn xem.Chỉ thay đổi giá trị ô A1 thì nó sẽ chạy code nhé.
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Address = "$A$1" Then tach
End Sub
Mã:
Sub tach()
Dim arr, i As Long, j As Long, a As Long, lr As Long, b As Long, T, arr1, s As String
With Sheet1
     lr = .Range("a" & Rows.Count).End(xlUp).Row
     ReDim arr(1 To lr * 50, 1 To 10)
     For i = 1 To lr
         T = Split(Chr(10) & .Cells(i, 1).Value, Chr(10))
         For j = 1 To UBound(T)
          If Len(T(j)) Then
             a = a + 1
             arr(a, 1) = T(j)
          End If
         Next j
    Next i
End With
   ReDim arr1(1 To a, 1 To 7)
   For i = 1 To a
       T = Split(" " & Trim(arr(i, 1)), " ")
       b = UBound(T)
       If b < 7 Then
          arr1(i, 1) = arr(i, 1)
       Else
           arr1(i, 1) = T(1)
           arr1(i, 2) = T(2)
           arr1(i, 3) = T(3)
           arr1(i, 7) = T(b)
           arr1(i, 6) = T(b - 1)
           arr1(i, 5) = T(b - 2)
           s = T(4)
          For j = 5 To b - 3
              s = s & " " & T(j)
          Next j
          arr1(i, 4) = s
      End If
  Next i
With Sheet2
     lr = .Range("A" & Rows.Count).End(xlUp).Row
     .Range("A1:G" & lr).ClearContents
     .Range("a1").Resize(a, 7).Value = arr1
End With
End Sub
 

File đính kèm

  • tach.xlsm
    30.5 KB · Đọc: 7
Upvote 0
Cần phải xác định lr*50, a so với số dòng lớn nhất của bảng tính.
Sử lý thế này được không anh.
Mã:
Sub tach()
Dim arr, i As Long, j As Long, a As Long, lr As Long, b As Long, T, arr1, s As String, c As Long
With Sheet1
     lr = .Range("a" & Rows.Count).End(xlUp).Row
     b = lr * 50
     If b > .Rows.Count Then b = .Rows.Count
     ReDim arr(1 To lr * 50, 1 To 10)
     For i = 1 To lr
         T = Split(Chr(10) & .Cells(i, 1).Value, Chr(10))
         For j = 1 To UBound(T)
          If Len(T(j)) Then
             a = a + 1
             arr(a, 1) = T(j)
             If a > .Rows.Count Then MsgBox "du lieu qua lon": Exit Sub
          End If
         Next j
    Next i
End With
   ReDim arr1(1 To a, 1 To 7)
   For i = 1 To a
       T = Split(" " & Trim(arr(i, 1)), " ")
       b = UBound(T)
       If b < 7 Then
          arr1(i, 1) = arr(i, 1)
       Else
           arr1(i, 1) = T(1)
           arr1(i, 2) = T(2)
           arr1(i, 3) = T(3)
           arr1(i, 7) = T(b)
           arr1(i, 6) = T(b - 1)
           arr1(i, 5) = T(b - 2)
           s = T(4)
          For j = 5 To b - 3
              s = s & " " & T(j)
          Next j
          arr1(i, 4) = s
      End If
  Next i
With Sheet2
     lr = .Range("A" & Rows.Count).End(xlUp).Row
     .Range("A1:G" & lr).ClearContents
     .Range("a1").Resize(a, 7).Value = arr1
End With
End Sub
Bài đã được tự động gộp:

Trường hợp code Anh khi copy dữ liệu khác vào thì code không chạy đó Anh.
Bài đã được tự động gộp:


Bạn có cách viết phương thức đó được không?
Cảm ơn bạn nhiều!
Bạn xem nó báo lỗi ở đâu vậy.
 
Upvote 0
Xử lý:
PHP:
Sub tach()
Dim maxRow as long
maxRow = rows.count
'...
Redim arr(1 To maxRow, 1 To 10)
'...
a = a + 1
if a > maxRow then msgbox "Kết quả nhiều hơn số dòng của bảng tính " & maxRow & vbnewline & "Chỉ xử lý tới đây!": Exit For
arr(a, 1) = T(j)
'...
End Sub()
 
Upvote 0
Xử lý:
PHP:
Sub tach()
Dim maxRow as long
maxRow = rows.count
'...
Redim arr(1 To maxRow, 1 To 10)
'...
a = a + 1
if a > maxRow then msgbox "Kết quả nhiều hơn số dòng của bảng tính " & maxRow & vbnewline & "Chỉ xử lý tới đây!": Exit For
arr(a, 1) = T(j)
'...
End Sub()
Xữ lí:
Excel 2007 có trên 1 triệu dòng.
Redim arr(1 To maxRow, 1 To 10) cho ra một mảng 10 triệu phần tử.
Nếu dữ liệu string thì khả năng bể ổ bộ nhớ xảy ra trước khi hết số dòng.
 
Upvote 0
Xữ lí:
Excel 2007 có trên 1 triệu dòng.
Redim arr(1 To maxRow, 1 To 10) cho ra một mảng 10 triệu phần tử.
Nếu dữ liệu string thì khả năng bể ổ bộ nhớ xảy ra trước khi hết số dòng.
Vẫn quá nhỏ anh ạ.
Em tăng Redim arr(1 To maxRow*10, 1 To 10*5) vẫn chạy bình thường. :)

1550683974249.png
 
Upvote 0
Web KT
Back
Top Bottom