[Hỏi] VBA tách chuỗi ngăn cách bởi dấu "+" trong một dòng thành nhiều dòng. (1 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
K

ketoanvien1985

Thành viên mới
Tham gia
8/7/15
Bài viết
33
Được thích
0
Em xin chào Anh/Chị GPE,

Hiện tại em có 1 yêu cầu là tách chuỗi trong 1 dòng thành nhiều dòng ( như trong file đính kèm em có làm mẫu sẵn, các chuỗi cách nhau bởi dấu "+"), nhờ anh/chị giúp em code VBA cho trường hợp này ạ.

Yêu cầu là không được insert dòng ( Chỉ được đẩy dữ liệu xuống), vì xung quanh đó em còn nhiều dữ liệu khác.

Mong các anh/chị xem giúp, em cảm ơn nhiều.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
hpkhuong đã viết:
Mã: 
Option Explicit
Public Sub GPE()
Dim Arr, dArr, I As Long, J As Long, K As Long, Tam, Tem, X As Long
Application.ScreenUpdating = False
With Sheet1
    Arr = .Range("H5", .Range("H65000").End(3)).Resize(, 3).Value
ReDim dArr(1 To UBound(Arr) * 3, 1 To 3)
For I = 1 To UBound(Arr)
    If Arr(I, 1) <> Tem Then
        K = K + 1
        For J = 1 To 3
            dArr(K, J) = Arr(I, J)
        Next J
        Tem = Arr(I, 1)
    End If
    If InStr(1, Arr(I, 2), "+", 1) Then
        Tam = Split(Arr(I, 2), "+")
        For X = 0 To UBound(Tam)
            K = K + 1
            dArr(K, 2) = Tam(X)
            dArr(K, 3) = Arr(I, 3)
        Next X
    End If
Next I
    .Range("N5").Resize(1000, 3).ClearContents
    .Range("N5").Resize(K, 3) = dArr
End With
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn Anh rất nhiều, Code chạy rất ok.
 
Upvote 0
Viết thành hàm tổng quát

hpkhuong đã viết:
Mã: 
Option Explicit
Public Sub GPE()
Dim Arr, dArr, I As Long, J As Long, K As Long, Tam, Tem, X As Long
Application.ScreenUpdating = False
With Sheet1
    Arr = .Range("H5", .Range("H65000").End(3)).Resize(, 3).Value
ReDim dArr(1 To UBound(Arr) * 3, 1 To 3)
For I = 1 To UBound(Arr)
    If Arr(I, 1) <> Tem Then
        K = K + 1
        For J = 1 To 3
            dArr(K, J) = Arr(I, J)
        Next J
        Tem = Arr(I, 1)
    End If
    If InStr(1, Arr(I, 2), "+", 1) Then
        Tam = Split(Arr(I, 2), "+")
        For X = 0 To UBound(Tam)
            K = K + 1
            dArr(K, 2) = Tam(X)
            dArr(K, 3) = Arr(I, 3)
        Next X
    End If
Next I
    .Range("N5").Resize(1000, 3).ClearContents
    .Range("N5").Resize(K, 3) = dArr
End With
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

Anh có thể sửa thành hàm tổng quát được ko anh, ở Sheet bất kỳ
 
Upvote 0
quyenpv đã viết:
Anh có thể sửa thành hàm tổng quát được ko anh, ở Sheet bất kỳ
Nhấp chuột vào đây để mở rộng...
Cái này là sub mà bạn, nếu muốn áp dụng cho sheet bất kỳ có thể sửa lại như sau (Xin lỗi mượn code của bạn hpkhuong nhé!):
Mã: 
Option Explicit
Public Sub GPE(sh As Worksheet)
Dim Arr, dArr, I As Long, J As Long, K As Long, Tam, Tem, X As Long
Application.ScreenUpdating = False
With sh
    Arr = .Range("H5", .Range("H65000").End(3)).Resize(, 3).Value
ReDim dArr(1 To UBound(Arr) * 3, 1 To 3)
For I = 1 To UBound(Arr)
    If Arr(I, 1) <> Tem Then
        K = K + 1
        For J = 1 To 3
            dArr(K, J) = Arr(I, J)
        Next J
        Tem = Arr(I, 1)
    End If
    If InStr(1, Arr(I, 2), "+", 1) Then
        Tam = Split(Arr(I, 2), "+")
        For X = 0 To UBound(Tam)
            K = K + 1
            dArr(K, 2) = Tam(X)
            dArr(K, 3) = Arr(I, 3)
        Next X
    End If
Next I
    .Range("N5").Resize(1000, 3).ClearContents
    .Range("N5").Resize(K, 3) = dArr
End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
hpkhuong đã viết:
Muốn ở sheet bất kỳ thì bạn bỏ With ... End with đi

Đã bỏ with ---end with thì chý í bỏ luôn dấu chấm trước đối tượng của sheet đó...
Ví dụ

Arr = .Range("H5", .Range("H65000").End(3)).Resize(, 3).Value

Thành

Arr = Range("H5", Range("H65000").End(3)).Resize(, 3).Value


Một khi đã bỏ rồi thì khi ở sheet nào, chạy sub thì chỉ có tác dụng tại sheet mình đang đứng thôi...
Nhấp chuột vào đây để mở rộng...
Em nghĩ mình đổi With sheet1 thành With Activesheet thì có thể chạy với sheet bất kỳ rồi. Không biết như thế có ổn không anh?
 
Upvote 0
Xin chào anh hpkhuong,

Sau khi test code của anh, có vấn để như sau:

1- nếu 2 mặc hàng giống nhau mà nằm gần nhau thì khi chuyển qua, nó chỉ hiển thị được 1 cái.>> Cần hiển thị đầy đủ.

2- Em xin nâng cao chút xíu: sheet2 em có thêm diễn giải của những mã hàng mới tách ra, sau khi phân tách mã, nó sẽ lấy thông tin diễn giải từ sheet2 để điền vào, cái nào ko có thì bỏ trống. ( e có up thêm file đính kèm)

Nhờ anh xem xét giúp em nha.
 

File đính kèm

Upvote 0
ketoanvien1985 đã viết:
Xin chào anh hpkhuong,

Sau khi test code của anh, có vấn để như sau:

1- nếu 2 mặc hàng giống nhau mà nằm gần nhau thì khi chuyển qua, nó chỉ hiển thị được 1 cái.>> Cần hiển thị đầy đủ.

2- Em xin nâng cao chút xíu: sheet2 em có thêm diễn giải của những mã hàng mới tách ra, sau khi phân tách mã, nó sẽ lấy thông tin diễn giải từ sheet2 để điền vào, cái nào ko có thì bỏ trống. ( e có up thêm file đính kèm)

Nhờ anh xem xét giúp em nha.
Nhấp chuột vào đây để mở rộng...
hpkhuong bữa nay phải ở nhà chơi với con rồi. Bạn áp dụng code dưới đây xem đúng ý chưa nhé:
Mã: 
Public Sub GPE()
Dim Arr(), dArr, vlArr(1 To 10000, 1 To 3), I As Long, J As Long, K As Long
With Sheet1
Arr = .Range(.[H5], .[J65000].End(xlUp)).Value
For I = 1 To UBound(Arr, 1)
   K = K + 1
   For J = 1 To 3
        vlArr(K, J) = Arr(I, J)
   Next J
   If InStr(Arr(I, 2), "+") Then
    dArr = Split(Arr(I, 2), "+")
    For J = LBound(dArr) To UBound(dArr)
        K = K + 1
        vlArr(K, 2) = dArr(J)
        vlArr(K, 3) = Arr(I, 3)
    Next J
   End If
Next I
.[N5:P10000].ClearContents
.[N5].Resize(K, 3) = vlArr
End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
giangleloi đã viết:
hpkhuong bữa nay phải ở nhà chơi với con rồi. Bạn áp dụng code dưới đây xem đúng ý chưa nhé:
Mã: 
Public Sub GPE()
Dim Arr(), dArr, vlArr(1 To 10000, 1 To 3), I As Long, J As Long, K As Long
With Sheet1
Arr = .Range(.[H5], .[J65000].End(xlUp)).Value
For I = 1 To UBound(Arr, 1)
   K = K + 1
   For J = 1 To 3
        vlArr(K, J) = Arr(I, J)
   Next J
   If InStr(Arr(I, 2), "+") Then
    dArr = Split(Arr(I, 2), "+")
    For J = LBound(dArr) To UBound(dArr)
        K = K + 1
        vlArr(K, 2) = dArr(J)
        vlArr(K, 3) = Arr(I, 3)
    Next J
   End If
Next I
.[N5:P10000].ClearContents
.[N5].Resize(K, 3) = vlArr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh giangleloi,
Code chạy ok rồi anh ạ, anh giúp em phần thứ 2 luôn nha, lấy thông tin diễn giải từ sheet2 để điền vào các mã hàng mới tách ra.
 
Upvote 0
ketoanvien1985 đã viết:
Cảm ơn anh giangleloi,
Code chạy ok rồi anh ạ, anh giúp em phần thứ 2 luôn nha, lấy thông tin diễn giải từ sheet2 để điền vào các mã hàng mới tách ra.
Nhấp chuột vào đây để mở rộng...
Sáng hông để ý cái yêu cầu thứ 2, bạn thử chạy code sau và phản hồi lại nhé:
Mã: 
Public Sub GPE()
Dim Arr(), dArr, vlArr(), I As Long, J As Long, K As Long
With Sheet1
Arr = .Range(.[H5], .[J65000].End(xlUp)).Value
ReDim vlArr(1 To UBound(Arr, 1) * 5, 1 To 3)
For I = 1 To UBound(Arr, 1)
   K = K + 1
   For J = 1 To 3
        vlArr(K, J) = Arr(I, J)
   Next J
   If InStr(Arr(I, 2), "+") Then
    dArr = Split(Arr(I, 2), "+")
    For J = LBound(dArr) To UBound(dArr)
        K = K + 1
        vlArr(K, 2) = dArr(J)
        vlArr(K, 3) = Arr(I, 3)
    Next J
   End If
Next I
.[N5:Q10000].ClearContents
.[N5].Resize(K, 3) = vlArr
With Sheet2
dArr = .Range(.[D4], .[E65000].End(xlUp)).Value
End With
Arr = .Range(.[O5], .[O65000].End(xlUp)).Value
ReDim vlArr(1 To UBound(Arr, 1), 1 To 1)
 For I = 1 To UBound(Arr, 1)
   For J = 1 To UBound(dArr, 1)
    If Arr(I, 1) = dArr(J, 2) Then
       vlArr(I, 1) = dArr(J, 1)
    End If
   Next J
Next I
.[Q5].Resize(I - 1) = vlArr
End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
giangleloi đã viết:
Sáng hông để ý cái yêu cầu thứ 2, bạn thử chạy code sau và phản hồi lại nhé:
Mã: 
Public Sub GPE()
Dim Arr(), dArr, vlArr(), I As Long, J As Long, K As Long
With Sheet1
Arr = .Range(.[H5], .[J65000].End(xlUp)).Value
ReDim vlArr(1 To UBound(Arr, 1) * 5, 1 To 3)
For I = 1 To UBound(Arr, 1)
   K = K + 1
   For J = 1 To 3
        vlArr(K, J) = Arr(I, J)
   Next J
   If InStr(Arr(I, 2), "+") Then
    dArr = Split(Arr(I, 2), "+")
    For J = LBound(dArr) To UBound(dArr)
        K = K + 1
        vlArr(K, 2) = dArr(J)
        vlArr(K, 3) = Arr(I, 3)
    Next J
   End If
Next I
.[N5:Q10000].ClearContents
.[N5].Resize(K, 3) = vlArr
With Sheet2
dArr = .Range(.[D4], .[E65000].End(xlUp)).Value
End With
Arr = .Range(.[O5], .[O65000].End(xlUp)).Value
ReDim vlArr(1 To UBound(Arr, 1), 1 To 1)
 For I = 1 To UBound(Arr, 1)
   For J = 1 To UBound(dArr, 1)
    If Arr(I, 1) = dArr(J, 2) Then
       vlArr(I, 1) = dArr(J, 1)
    End If
   Next J
Next I
.[Q5].Resize(I - 1) = vlArr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em muốn nó hiển thị bên cột diễn giải luôn anh ( Cột N), nhưng khi em sửa Q5 thành N5 thì nó mất hết kết quả cột N của code chạy trước.
 
Upvote 0
hpkhuong đã viết:
Mã: 
Option Explicit
Public Sub GPE()
Dim Arr, dArr, sArr, I As Long, J As Long, K As Long, Tam, Tem, X As Long, Y As Long
Application.ScreenUpdating = False
With Sheet2
    sArr = .Range("D4", .Range("E4").End(4)).Value
End With
With Sheet1
    Arr = .Range("H5", .Range("H65000").End(3)).Resize(, 3).Value
ReDim dArr(1 To UBound(Arr) * 3, 1 To 3)
For I = 1 To UBound(Arr)
If Len(Arr(I, 1)) Then
        K = K + 1
        For J = 1 To 3
            dArr(K, J) = Arr(I, J)
        Next J
    If InStr(1, Arr(I, 2), "+", 1) Then
        Tam = Split(Arr(I, 2), "+")
        For X = 0 To UBound(Tam)
            K = K + 1
            For Y = 1 To UBound(sArr)
                If Tam(X) = sArr(Y, 2) Then
                    dArr(K, 1) = sArr(Y, 1): Exit For
                End If
            Next Y
            dArr(K, 2) = Tam(X)
            dArr(K, 3) = Arr(I, 3)
        Next X
    End If
End If
Next I
    .Range("N5").Resize(5000, 3).ClearContents
    .Range("N5").Resize(K, 3) = dArr
End With
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Code chạy tốt rồi nha anh,

Cảm ơn các anh rất nhiều, bữa giờ em bận việc quá không lên diễn đàn được.
 
Upvote 0
Xin chào anh chị GPE,

Em cũng đang gặp vấn đề như chủ thớt này nhưng yêu cầu của em là sau khi tách ra nó tự nhân số lượng luôn.

Em có gửi kèm file, mong anh chị xem giúp em nha.
Ví dụ:
diễn giải ! Số lượng
A+2*B+3*C ! 2

khi tách ra nó sẽ là:
diễn giải ! Số lượng
A+2*B+3*C ! 2
A ! 2
B ! 4
C ! 6
 

File đính kèm

Upvote 0
Hoangkhoi2012 đã viết:
Xin chào anh chị GPE,

Em cũng đang gặp vấn đề như chủ thớt này nhưng yêu cầu của em là sau khi tách ra nó tự nhân số lượng luôn.

Em có gửi kèm file, mong anh chị xem giúp em nha.
Ví dụ:
diễn giải ! Số lượng
A+2*B+3*C ! 2

khi tách ra nó sẽ là:
diễn giải ! Số lượng
A+2*B+3*C ! 2
A ! 2
B ! 4
C ! 6
Nhấp chuột vào đây để mở rộng...
Nếu số nhân luôn đứng trước thì thử chạy code này xem sao:
Mã: 
Public Sub ToTe()
    Dim Vung, I, kK, K, Kq, Gom, Tach, Cll, TachTiep
    Set Vung = Range([H5], [H50000].End(xlUp)).Resize(, 3)
    Gom = Join(Application.WorksheetFunction.Transpose(Vung.Columns(2)), " ")
    K = 2 * Vung.Rows.Count + Len(Gom) - Len(Replace(Gom, "+", ""))
    ReDim Kq(1 To K, 1 To 3)
        For I = 1 To Vung.Rows.Count
            kK = kK + 1
            Kq(kK, 1) = Vung(I, 1): Kq(kK, 2) = Vung(I, 2): Kq(kK, 3) = Vung(I, 3)
                If InStr(Vung(I, 2), "+") Then
                    Tach = Split(Vung(I, 2), "+")
                    For Each Cll In Tach
                        kK = kK + 1
                            If InStr(Cll, "*") Then
                                TachTiep = Split(Cll, "*")
                                Kq(kK, 2) = TachTiep(1): Kq(kK, 3) = TachTiep(0) * Vung(I, 3)
                            Else
                                Kq(kK, 2) = Cll: Kq(kK, 3) = Vung(I, 3)
                            End If
                    Next Cll
                 End If
        Next I
    [Q5].Resize(kK, 3) = Kq
End Sub
Thân
 
Upvote 0
Hoangkhoi2012 đã viết:
Xin chào anh chị GPE,

Em cũng đang gặp vấn đề như chủ thớt này nhưng yêu cầu của em là sau khi tách ra nó tự nhân số lượng luôn.

Em có gửi kèm file, mong anh chị xem giúp em nha.
Ví dụ:
diễn giải ! Số lượng
A+2*B+3*C ! 2

khi tách ra nó sẽ là:
diễn giải ! Số lượng
A+2*B+3*C ! 2
A ! 2
B ! 4
C ! 6
Nhấp chuột vào đây để mở rộng...
Kiếm đoạn sau:
Mã: 
  For X = 0 To UBound(Tam)
   ................................        
  Next X
Sửa thành vầy:
Mã: 
   For X = 0 To UBound(Tam)
     K = K + 1
        If InStr(Tam(X), "*") Then
          dArr(K, 2) = Mid(Tam(X), InStr(Tam(X), "*") + 1, Len(Tam(X)))
          dArr(K, 3) = Val(Left(Tam(X), InStr(Tam(X), "*") - 1)) * Arr(I, 3)
         Else
          dArr(K, 2) = Tam(X)
          dArr(K, 3) = Arr(I, 3)
        End If
   Next X
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

E
Đánh số cho các cặp số chứng từ và số chứng từ đối ứng (1 người xem)
Trả lời
16
Đọc
325
Phan Thế Hiệp
Phan Thế Hiệp
Y
Lấy dữ liệu từ sheet chi tiết sang sheet tổng hợp hàng dọc (1 người xem)
Trả lời
5
Đọc
521
SA_DQ
SA_DQ
N
Hàm tính chuỗi số trong 1 ô hoặc 1 dãy ô ra tổng kết quả.
Trả lời
2
Đọc
92
minhminh27
minhminh27
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
382
Đọc
45K
TomRuoi
TomRuoi
NguyenthiH
Mở file Excel có Pass Open (2 người xem)
Trả lời
39
Đọc
3K
Hoàng Tuấn 868
H
M
Tách dữ liệu trong 1 file thành nhiều sheet theo số lượng dòng
    • Ngạc nhiên
Trả lời
25
Đọc
3K
Hoàng Tuấn 868
H
T
Tìm số hóa đơn trong chuỗi (1 người xem)
Trả lời
11
Đọc
419
thao nguyen01
T
T
  • Question Question
Nhờ ACE cao thủ hỗ trợ mình có một chương trình EXCEL về phân công lớp cho giáo viên (1 người xem)
Trả lời
6
Đọc
318
DeTong
D
T
Nhờ các anh chị sửa dùm công thức ạ.
Trả lời
10
Đọc
208
trantrungvinh1989
T
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
Trả lời
24
Đọc
2K
phuongdaik98
P
Phan Thế Hiệp
Quy đổi từ Thu nhập sau thuế (TNCN) ra Thu nhập tính thuế
    • Yêu thích
    • Thích
Trả lời
1
Đọc
338
Phan Thế Hiệp
Phan Thế Hiệp
V
Quên mật khẩu file excel
Trả lời
25
Đọc
2K
YêuCN
Y
Nguyen Rem
  • Question Question
Lỗi "User-defined type not defined" khi khai báo biến
Trả lời
28
Đọc
2K
nguyendang95
N
OverAC
  • Dán lên cao
  • Suggestion Suggestion
Chúc mừng sinh nhật GiaiPhapExcel 19 tuổi và tặng ebook "Lập trình VBA phần cơ bản."
    • Thích
    • Yêu thích
Trả lời
5
Đọc
1K
longlacda
L
V
Công thức để phân công chuyên môn cho giáo viên (1 người xem)
Trả lời
5
Đọc
295
vietvanyen
V
G
AddIn convert ngày dương lịch sang âm lịch và ngược lại + đọc ngày tháng
Trả lời
20
Đọc
10K
du trung kien
D
8
Hàm trong excel
Trả lời
3
Đọc
118
Hoàng Tuấn 868
H
N
Chuyển giờ công từ bảng công vào bảng tính (1 người xem)
Trả lời
16
Đọc
351
ngouyen1505
N
N
Tạo COM Add-In bằng Visual C++
    • Thích
Trả lời
7
Đọc
707
nguyendang95
N
Nga1852k
lỗi excel không chèn được dòng và không xóa được dòng
Trả lời
2
Đọc
154
Nga1852k
Nga1852k
Xem thêm…

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

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

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom