xử lý chuỗi ký tự bằng vba (1 người xem)

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.

VetMini · 20/3/19

Mã:

Sub TachTumLum()
' split one long string into segments
' this procedure assumes that the string is normal, ie you dont have to trim

Const SHEETNAME = "nhaplieu"
Const SEGLEN = 500
Const WBOUNDARY = " " ' if punctuation marks also count, you need a string list
Dim str As String
Dim segSt As Integer, segEn As Integer, finalPos As Integer ' segment start, end & final position
Dim segments() As Integer, segTot As Integer
' Firstly, establish an array of segment positions in the string
ReDim segments(1 To 2, 1 To 1)
str = Worksheets(SHEETNAME).Range("b3").Value ' read the original string
finalPos = Len(str)
segSt = 1
Do While segSt <= finalPos
  segEn = segSt + SEGLEN ' the position is 1 character beyond required segment length
  If segEn > finalPos Then
    segEn = finalPos
  Else
    Do While Mid(str, segEn, 1) <> WBOUNDARY ' find the word boundary
      segEn = segEn - 1
    Loop
    segEn = segEn - 1
  End If
  ' write the positions to array
  segTot = segTot + 1
  ReDim Preserve segments(1 To 2, 1 To segTot)
  segments(1, segTot) = segSt
  segments(2, segTot) = segEn
  ' Debug.Print Mid(str, segSt, segEn - segSt + 1)
  ' Mid(str, segSt, segEn - segSt + 1) is the string segment we want
  ' add code to write them to worksheet here
  segSt = segEn + 2
Loop
' Secondly, write the segments down onto worksheet
Const BLOCKCOLS = 6
Const WRITESTART = "D5"
Dim rg As Range, i As Integer, col As Integer, row As Integer
Set rg = Worksheets(SHEETNAME).Range(WRITESTART)
row = 1: col = 0
For i = 1 To segTot
  col = col + 1
  If col > BLOCKCOLS Then row = row + 1: col = 1
  rg.Cells(row, col).Value = Mid(str, segments(1, i), segments(2, i) - segments(1, i) + 1)
Next i
End Sub

AutoReply · 21/3/19

VetMini đã viết:

Mã:

Sub TachTumLum()
' split one long string into segments
' this procedure assumes that the string is normal, ie you dont have to trim

Const SHEETNAME = "nhaplieu"
Const SEGLEN = 500
Const WBOUNDARY = " " ' if punctuation marks also count, you need a string list
Dim str As String
Dim segSt As Integer, segEn As Integer, finalPos As Integer ' segment start, end & final position
Dim segments() As Integer, segTot As Integer
' Firstly, establish an array of segment positions in the string
ReDim segments(1 To 2, 1 To 1)
str = Worksheets(SHEETNAME).Range("b3").Value ' read the original string
finalPos = Len(str)
segSt = 1
Do While segSt <= finalPos
  segEn = segSt + SEGLEN ' the position is 1 character beyond required segment length
  If segEn > finalPos Then
    segEn = finalPos
  Else
    Do While Mid(str, segEn, 1) <> WBOUNDARY ' find the word boundary
      segEn = segEn - 1
    Loop
    segEn = segEn - 1
  End If
  ' write the positions to array
  segTot = segTot + 1
  ReDim Preserve segments(1 To 2, 1 To segTot)
  segments(1, segTot) = segSt
  segments(2, segTot) = segEn
  ' Debug.Print Mid(str, segSt, segEn - segSt + 1)
  ' Mid(str, segSt, segEn - segSt + 1) is the string segment we want
  ' add code to write them to worksheet here
  segSt = segEn + 2
Loop
' Secondly, write the segments down onto worksheet
Const BLOCKCOLS = 6
Const WRITESTART = "D5"
Dim rg As Range, i As Integer, col As Integer, row As Integer
Set rg = Worksheets(SHEETNAME).Range(WRITESTART)
row = 1: col = 0
For i = 1 To segTot
  col = col + 1
  If col > BLOCKCOLS Then row = row + 1: col = 1
  rg.Cells(row, col).Value = Mid(str, segments(1, i), segments(2, i) - segments(1, i) + 1)
Next i
End Sub

anh gì ơi, em đọc chú thích tiếng Tây khó hiểu quá, anh có thể chú thích lại tiếng khác cho dễ hiểu được không ạ ?

VetMini · 21/3/19

AutoReply đã viết:
anh gì ơi, em đọc chú thích tiếng Tây khó hiểu quá, anh có thể chú thích lại tiếng khác cho dễ hiểu được không ạ ?

chú thích là đủ rồi, đâu có cần cô thích.

minhlq123 · 21/3/19

VetMini đã viết:

Mã:

Sub TachTumLum()
' split one long string into segments
' this procedure assumes that the string is normal, ie you dont have to trim

Const SHEETNAME = "nhaplieu"
Const SEGLEN = 500
Const WBOUNDARY = " " ' if punctuation marks also count, you need a string list
Dim str As String
Dim segSt As Integer, segEn As Integer, finalPos As Integer ' segment start, end & final position
Dim segments() As Integer, segTot As Integer
' Firstly, establish an array of segment positions in the string
ReDim segments(1 To 2, 1 To 1)
str = Worksheets(SHEETNAME).Range("b3").Value ' read the original string
finalPos = Len(str)
segSt = 1
Do While segSt <= finalPos
  segEn = segSt + SEGLEN ' the position is 1 character beyond required segment length
  If segEn > finalPos Then
    segEn = finalPos
  Else
    Do While Mid(str, segEn, 1) <> WBOUNDARY ' find the word boundary
      segEn = segEn - 1
    Loop
    segEn = segEn - 1
  End If
  ' write the positions to array
  segTot = segTot + 1
  ReDim Preserve segments(1 To 2, 1 To segTot)
  segments(1, segTot) = segSt
  segments(2, segTot) = segEn
  ' Debug.Print Mid(str, segSt, segEn - segSt + 1)
  ' Mid(str, segSt, segEn - segSt + 1) is the string segment we want
  ' add code to write them to worksheet here
  segSt = segEn + 2
Loop
' Secondly, write the segments down onto worksheet
Const BLOCKCOLS = 6
Const WRITESTART = "D5"
Dim rg As Range, i As Integer, col As Integer, row As Integer
Set rg = Worksheets(SHEETNAME).Range(WRITESTART)
row = 1: col = 0
For i = 1 To segTot
  col = col + 1
  If col > BLOCKCOLS Then row = row + 1: col = 1
  rg.Cells(row, col).Value = Mid(str, segments(1, i), segments(2, i) - segments(1, i) + 1)
Next i
End Sub

1. code chạy được anh ah, tuy nhiên em muốn kiểm soát điều kiện điền là cột B có giá trị thì cả dòng đó ko được điền, cụ thể là em muốn nó điền vào các ô có màu xanh lá cây. anh xem hình vẽ ah.
2. cái ô keyword sẽ mất bớt ký tự khi điền vào 1 ô( tức là ví dụ ô key word có 5 chữ cái là a,b,c,d khi điền vào ô a1 chữ a, a2 chữ b, a3 chữ c thì keyword còn lại trong ô chỉ còn là c,d).

Bài đã được tự động gộp: 21/3/19

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

hi anh, cái keyword mất dần đi để làm đầu bài cho 1 bài toán khác, tóm lại là em muốn tối ưu keyword. cái ô chứa keyword đó như 1 cái túi, mình thò tay rải vào các ô thì cái túi đó vơi dần, sau khi rải mà còn thừa thì chỗ keyword còn lại sẽ được đem đi làm việc khác ah

xử lý chuỗi ký tự bằng vba (1 người xem)

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

Thành viên mới

File đính kèm

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

/(hông là gì!

Đang đi tìm hòn đá

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

Đang đi tìm hòn đá

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

Đang đi tìm hòn đá

Thành viên tiêu biểu

Đang đi tìm hòn đá

Thành viên mới

Thời gian đếm ngược.