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

huonglien1901

GPE là ngôi nhà thứ 2 của tôi!!!
Tham gia ngày
17 Tháng tư 2016
Bài viết
2,290
Được thích
1,897
Điểm
360
Tuổi
28
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

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,512
Được thích
2,362
Điểm
360
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

huonglien1901

GPE là ngôi nhà thứ 2 của tôi!!!
Tham gia ngày
17 Tháng tư 2016
Bài viết
2,290
Được thích
1,897
Điểm
360
Tuổi
28
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?
 

huonglien1901

GPE là ngôi nhà thứ 2 của tôi!!!
Tham gia ngày
17 Tháng tư 2016
Bài viết
2,290
Được thích
1,897
Điểm
360
Tuổi
28
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:

huonglien1901

GPE là ngôi nhà thứ 2 của tôi!!!
Tham gia ngày
17 Tháng tư 2016
Bài viết
2,290
Được thích
1,897
Điểm
360
Tuổi
28
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!
 

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,512
Được thích
2,362
Điểm
360
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

snow25

Thành viên gắn bó
Tham gia ngày
24 Tháng bảy 2018
Bài viết
2,512
Được thích
2,362
Điểm
360
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.
 

befaint

|||||||||||||
Tham gia ngày
6 Tháng một 2011
Bài viết
9,164
Được thích
10,641
Điểm
1,560
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()
 

VetMini

Bàn phiếm qua bàn phím
Tham gia ngày
21 Tháng mười hai 2012
Bài viết
8,313
Được thích
9,660
Điểm
560
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.
 

befaint

|||||||||||||
Tham gia ngày
6 Tháng một 2011
Bài viết
9,164
Được thích
10,641
Điểm
1,560
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
 
Top Bottom