[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.
Web KT

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

A
Xin các bác chỉ giúp cách thống kê danh sách học sinh (3 người xem)
Trả lời
6
Đọc
77
Anhnn9
A
Việt Nguyễn 86
Excel hay bị tắt đột ngột và hiện trang trắng khi làm việc (1 người xem)
Trả lời
7
Đọc
255
Việt Nguyễn 86
Việt Nguyễn 86
4
EXCEL TỰ ĐỘNG MỞ TRÊN WEB
Trả lời
2
Đọc
88
4545
4
cadafi
Hướng dẫn tạo Macro chuyển số thành chữ trong Open Office 3.1 (Tiếng Việt Unicode) (1 người xem)
Trả lời
11
Đọc
25K
minnad123
M
Nguyễn Duy Tuân
Lập trình VBA với Google Drive, OneDrive, DropBox cho Upload-Download-Copy-Move...
    • Cảm ơn
Trả lời
2
Đọc
137
Nguyễn Duy Tuân
Nguyễn Duy Tuân
T
hỏi về đếm số ngày doanh thu tăng và giảm
Trả lời
5
Đọc
61
VetMini
V
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711) (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
263
Đọc
28K
ongke0711
ongke0711
T
xin công thức tính được số người còn lại theo từng cột
Trả lời
1
Đọc
48
bebo021999
B
D
Hỏi về cách sử dụng data table
Trả lời
2
Đọc
71
ptm0412
ptm0412
HeSanbi
Office Tool Plus - Ứng dụng tải, cài đặt, gỡ bỏ, nhập khóa, xóa khóa bản quyền Office nhanh chóng (1 người xem)
    • Thích
Trả lời
0
Đọc
81
HeSanbi
HeSanbi
P
  • Question Question
Lấy giá trị duy nhất nhiều cột khác nhau
Trả lời
1
Đọc
54
BuiQuangThuan
B
A
  • Question Question
Em nhờ anh/chị/em/chú/bác giúp em viết code tổng hợp dữ liệu. em tính công thức nó nặng quá. em cám ơn
Trả lời
8
Đọc
158
VetMini
V
hieuxd
  • Question Question
Khi nhập dữ liệu tự động chèn thêm dòng khi số dòng trong bảng mẫu sắp hết
2
Trả lời
21
Đọc
24K
Bát Giới
Bát Giới
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA
Trả lời
10
Đọc
7K
VetMini
V
SA_DQ
[Xin hỏi] Cách tính số tiền bình quân của tài khoản trong 1 tháng
Trả lời
15
Đọc
300
ptm0412
ptm0412
dangvandang
Addin mở rộng cho xây dựng
    • Thích
2
Trả lời
34
Đọc
3K
vlba
V
M
  • Question Question
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
4
Đọc
141
mtbackup
M
N
Xin giúp e cách lọc dữ liệu bị trùng
Trả lời
3
Đọc
183
hoangtuaotrang_hp_vn
H
A
ExTools : Hơn 60 tính năng bổ sung cho Excel
    • Thích
Trả lời
3
Đọc
9K
mangat060083
M
anhtuan1066
  • Question Question
Đọc số thành chữ có phần thập phân
Trả lời
12
Đọc
8K
caocat
C
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom