xử lý chuỗi ký tự bằng vba

minhlq123 · 20/3/19

em xin phép được sửa lại yêu cầu. các anh xem giúp em với ạ.
+tách ra nhiều phần, mỗi phần 500 ký tự.
+Chỗ ngắt phải là khoảng trống, nếu tách ngay giữa từ thì phải thụt lùi lại ( <500) cho đủ từ
+ ô chứa keyword cứ mất dần sau mỗi lượt điền, như kiểu thò tay vào túi lấy ra rồi thì vơi bớt đi ấy
bài toán này là bài toán thực tế, hiện tại em đang làm bằng tay, mât rất nhiều công đoạn

snow25 · 20/3/19

minhlq123 đã viết:
hi các bạn, mình có 1 bài toán như thế này, ở 1 ô có chứa chuỗi gồm n từ (n ko xác định), em muốn tách chuỗi đó sang các ô liên tiếp, mỗi ô chứa 500 ký tự, sau khi điền đủ hết 500 ký tự trong 1 ô sẽ nhảy sang ô tiếp theo cứ thế đến khi nào ô chứa chuỗi bằng 0 thì dừng. bài toàn này làm ntn ah?

Vậy bạn viết Code theo kiểu.
Đầu tiên là đếm số ký tự của nó.Rồi chạy vòng lặp với step 500,dùng hàm mid mà tách ra.Không có ví dụ cụ thể nên chỉ vậy thôi.

SA_DQ · 20/3/19

Ô của bạn làm gì mà chứa lắm ký tự đến thế kia chứ?
Mình hơi nghi ngờ tính thực tiển của bài toán quá đi mất

VetMini · 20/3/19

Bài toán chuỗi không khó, những chi tiết luôn luôn phức tạp. Trình bày vừa tiếng Tây vừa viết tắt tùm lum thì cả chục bài mới ra kết quả.
Sửa lại tiếng Việt rõ ràng rồi nói chuyện tiếp.

minhlq123 · 20/3/19

VetMini đã viết:
Bài toán chuỗi không khó, những chi tiết luôn luôn phức tạp. Trình bày vừa tiếng Tây vừa viết tắt tùm lum thì cả chục bài mới ra kết quả.
Sửa lại tiếng Việt rõ ràng rồi nói chuyện tiếp.

em cảm ơn anh đã góp ý, em đã sửa lại, mong các anh giúp em với

snow25 · 20/3/19

minhlq123 đã viết:
em xin phép được sửa lại yêu cầu. các anh xem giúp em với ạ. bài toán này là bài toán thực tế, hiện tại em đang làm bằng tay, mât rất nhiều công đoạn

Bạn chạy thử code này xem thế nào nhé.

Mã:

Sub tach()
Dim arr(1 To 100, 1 To 6), i As Long, dk As String, a As Long, b As Long, T As Long, c As Long
With Sheets("nhaplieu")
     dk = .Range("B3").Value
     T = Len(dk)
     b = 1
     c = 500
     For i = 1 To T Step 500
         a = a + 1
         If a = 7 Then b = b + 1: a = 1
         If T - i < 500 Then c = T - i
         arr(a, b) = Mid(dk, i, c)
     Next i
     .Range("D5:I100").ClearContents
     If a Then .Range("D5").Resize(a, b).Value = arr
End With
End Sub

minhlq123 · 20/3/19

snow25 đã viết:

Bạn chạy thử code này xem thế nào nhé.

Mã:

Sub tach()
Dim arr(1 To 100, 1 To 6), i As Long, dk As String, a As Long, b As Long, T As Long, c As Long
With Sheets("nhaplieu")
     dk = .Range("B3").Value
     T = Len(dk)
     b = 1
     c = 500
     For i = 1 To T Step 500
         a = a + 1
         If a = 7 Then b = b + 1: a = 1
         If T - i < 500 Then c = T - i
         arr(a, b) = Mid(dk, i, c)
     Next i
     .Range("D5:I100").ClearContents
     If a Then .Range("D5").Resize(a, b).Value = arr
End With
End Sub

em cảm ơn anh ah. em thử tăng kích thước của chuỗi lên 18000 thì báo lỗi out of range ah. anh xem giúp em
lỗi dòng này: arr(a, b) = Mid(dk, i, c)

snow25 · 20/3/19

minhlq123 đã viết:
em cảm ơn anh ah. em thử tăng kích thước của chuỗi lên 18000 thì báo lỗi out of range ah. anh xem giúp em
lỗi dòng này: arr(a, b) = Mid(dk, i, c)

Vậy bạn dùng cái này.

Mã:

Sub tach()
Dim arr, i As Long, dk As String, a As Long, b As Long, T As Long, c As Long
With Sheets("nhaplieu")
     dk = .Range("B3").Value
     T = Len(dk)
     b = 1
     c = 500
     ReDim arr(1 To T / 6 / c, 1 To 6)
     For i = 1 To T Step 500
         a = a + 1
         If a = 7 Then b = b + 1: a = 1
         If T - i < 500 Then c = T - i
         arr(a, b) = Mid(dk, i, c)
     Next i
     .Range("D5:I100").ClearContents
     If a Then .Range("D5").Resize(a, b).Value = arr
End With
End Sub

minhlq123 · 20/3/19

snow25 đã viết:

Vậy bạn dùng cái này.

Mã:

Sub tach()
Dim arr, i As Long, dk As String, a As Long, b As Long, T As Long, c As Long
With Sheets("nhaplieu")
     dk = .Range("B3").Value
     T = Len(dk)
     b = 1
     c = 500
     ReDim arr(1 To T / 6 / c, 1 To 6)
     For i = 1 To T Step 500
         a = a + 1
         If a = 7 Then b = b + 1: a = 1
         If T - i < 500 Then c = T - i
         arr(a, b) = Mid(dk, i, c)
     Next i
     .Range("D5:I100").ClearContents
     If a Then .Range("D5").Resize(a, b).Value = arr
End With
End Sub

vẫn bị lỗi anh ah, laanf này em giảm xuống hẳn 3900 thì vẫn lỗi. code trước số ký tự trong chuỗi 13000 vẫn chạy được

snow25 · 20/3/19

minhlq123 đã viết:
vẫn bị lỗi anh ah, laanf này em giảm xuống hẳn 3900 thì vẫn lỗi. code trước số ký tự trong chuỗi 13000 vẫn chạy được

Bạn gửi file cái lỗi lên đây mình xem nào.

.Cái này là do khai báo thiếu mảng.

minhlq123 · 20/3/19

snow25 đã viết:
Bạn gửi file cái lỗi lên đây mình xem nào..Cái này là do khai báo thiếu mảng.

đây anh ah

snow25 · 20/3/19

minhlq123 đã viết:
vẫn bị lỗi anh ah, laanf này em giảm xuống hẳn 3900 thì vẫn lỗi. code trước số ký tự trong chuỗi 13000 vẫn chạy được

Bạn chạy cái này nhé lúc nãy viết ngược.

Mã:

Sub tach()
Dim arr, i As Long, dk As String, a As Long, b As Long, T As Long, c As Long, d As Long
With Sheets("nhaplieu")
     dk = .Range("B3").Value
     T = Len(dk)
     b = 1
     c = 500
     d = T / c / 6 + 1
     ReDim arr(1 To d, 1 To 6)
     For i = 1 To T Step 500
         a = a + 1
         If a = 7 Then b = b + 1: a = 1
         If T - i < 500 Then c = T - i
         arr(b, a) = Mid(dk, i, c)
     Next i
     .Range("D5:I100").ClearContents
      .Range("D5").Resize(b, 6).Value = arr
End With
End Sub

minhlq123 · 20/3/19

snow25 đã viết:

Bạn chạy cái này nhé lúc nãy viết ngược.

Mã:

Sub tach()
Dim arr, i As Long, dk As String, a As Long, b As Long, T As Long, c As Long, d As Long
With Sheets("nhaplieu")
     dk = .Range("B3").Value
     T = Len(dk)
     b = 1
     c = 500
     d = T / c / 6 + 1
     ReDim arr(1 To d, 1 To 6)
     For i = 1 To T Step 500
         a = a + 1
         If a = 7 Then b = b + 1: a = 1
         If T - i < 500 Then c = T - i
         arr(b, a) = Mid(dk, i, c)
     Next i
     .Range("D5:I100").ClearContents
      .Range("D5").Resize(b, 6).Value = arr
End With
End Sub

code chạy rất mượt anh ah,
còn phần điều kiện kiểm soát điền thì xử lý ntn hả anh. em muốn nó điền theo thứ tự như trong ảnh ( bỏ qua ko điền vào dòng trống), cột để xác định có điền hay không là cột B, ô nào ở cột B khác rỗng thì sẽ ko điền vào dòng đó

VetMini · 20/3/19

Theo tôi hiểu thì yêu cầu là tách ra nhiều phần, mỗi phần 500 ký tự.
Theo cách làm việc thông thường thì chỗ ngắt phải là khoảng trống, nếu tách ngay giữa từ thì phải thụt lùi lại ( <500) cho đủ từ. Nếu có điều kiện này thì code bài #12 không đạt.

@thớt: diễn tả bài thì tránh viết tắt. Bài đã rắc rối lại còn phải đoán từ viết tắt.

minhlq123 · 20/3/19

VetMini đã viết:
Theo tôi hiểu thì yêu cầu là tách ra nhiều phần, mỗi phần 500 ký tự.
Chỗ ngắt phải là khoảng trống, nếu tách ngay giữa từ thì phải thụt lùi lại ( <500) cho đủ từ. Theo điều kiện này thì code bài #12 không đạt.

chuẩn luôn anh ah. đúng là em định mô tả như thế và ô chứa keyword cứ mất dần sau mỗi lượt điền, như kiểu thò tay vào túi lấy ra rồi thì vơi bớt đi ấy ah.

HieuCD · 20/3/19

snow25 đã viết:

Vậy bạn dùng cái này.

Mã:

Sub tach()
Dim arr, i As Long, dk As String, a As Long, b As Long, T As Long, c As Long
With Sheets("nhaplieu")
     dk = .Range("B3").Value
     T = Len(dk)
     b = 1
     c = 500
     ReDim arr(1 To T / 6 / c, 1 To 6)
     For i = 1 To T Step 500
         a = a + 1
         If a = 7 Then b = b + 1: a = 1
         If T - i < 500 Then c = T - i
         arr(a, b) = Mid(dk, i, c)
     Next i
     .Range("D5:I100").ClearContents
     If a Then .Range("D5").Resize(a, b).Value = arr
End With
End Sub

Mãng arr khai báo thiếu 1 dòng

minhlq123 · 20/3/19

VetMini đã viết:
Bài đã rắc rối lại còn phải đoán từ viết tắt.

em xin ghi nhận

snow25 · 20/3/19

minhlq123 đã viết:
code chạy rất mượt anh ah,
còn phần điều kiện kiểm soát điền thì xử lý ntn hả anh. em muốn nó điền theo thứ tự như trong ảnh ( bỏ qua ko điền vào dòng trống), cột để xác định có điền hay không là cột B, ô nào ở cột B khác rỗng thì sẽ ko điền vào dòng đó

Bạn chạy code này nhé.Bạn thêm giá trị ô cần bỏ trống vào chỗ dks nhé.

Mã:

Sub tach()
Dim arr, i As Long, dk As String, a As Long, b As Long, T As Long, c As Long, d As Long, dks As String
With Sheets("nhaplieu")
     dks = "#12#16#17#"
     dk = .Range("B3").Value
     T = Len(dk)
     b = 1
     c = 500
     d = T / c / 6 + 100
     ReDim arr(1 To d, 1 To 6)
     For i = 1 To T Step 500
         a = a + 1
         If a = 7 Then
            b = b + 1
            Do While InStr(dks, "#" & b + 4 & "#") > 0
               b = b + 1
            Loop
            a = 1
          End If
         If T - i < 500 Then c = T - i
         arr(b, a) = Mid(dk, i, c)
     Next i
     .Range("D5:I1000").ClearContents
      .Range("D5").Resize(b, 6).Value = arr
End With
End Sub

minhlq123 · 20/3/19

snow25 đã viết:

Bạn chạy code này nhé.Bạn thêm giá trị ô cần bỏ trống vào chỗ dks nhé.

Mã:

Sub tach()
Dim arr, i As Long, dk As String, a As Long, b As Long, T As Long, c As Long, d As Long, dks As String
With Sheets("nhaplieu")
     dks = "#12#16#17#"
     dk = .Range("B3").Value
     T = Len(dk)
     b = 1
     c = 500
     d = T / c / 6 + 100
     ReDim arr(1 To d, 1 To 6)
     For i = 1 To T Step 500
         a = a + 1
         If a = 7 Then
            b = b + 1
            Do While InStr(dks, "#" & b + 4 & "#") > 0
               b = b + 1
            Loop
            a = 1
          End If
         If T - i < 500 Then c = T - i
         arr(b, a) = Mid(dk, i, c)
     Next i
     .Range("D5:I1000").ClearContents
      .Range("D5").Resize(b, 6).Value = arr
End With
End Sub

em cảm ơn anh ah. còn bài toán cho keyword nó bớt đi giá trị khi điền vào các ô kia thì làm thế nào hả anh? tức là nó cứ với dần ấy

snow25 · 20/3/19

minhlq123 đã viết:
em cảm ơn anh ah. còn bài toán cho keyword nó bớt đi giá trị khi điền vào các ô kia thì làm thế nào hả anh? tức là nó cứ với dần ấy

Không hiểu ý bạn lắm.Với dần là sao nhỉ.Nếu thế thì bạn cứ để nó chạy ra hết rồi xóa bằng tay cho nhanh.

xử lý chuỗi ký tự bằng vba

Thành viên mới

File đính kèm

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

/(hông là gì!

Ăn cùng góc phố

Thành viên mới

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

Thành viên mới

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

Thành viên mới

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

Thành viên mới

File đính kèm

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

Thành viên mới

File đính kèm

Ăn cùng góc phố

Thành viên mới

Chuyên gia GPE

Thành viên mới

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

Thành viên mới

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

Facebook

Group