Ghép chữ theo thứ tự với n (500-1000) hàng, cột thì tùy ý

Liên hệ QC
Quang86vn

Quang86vn

Thành viên mới
Tham gia
21/5/17
Bài viết
18
Được thích
0
Giới tính
Nam
Em nhờ các bác xem qua file dữ liệu và code chạy. Ghép chữ theo thứ tự với n (500-1000) hàng, cột thì tùy ý. Hiện tại code chỉ chạy đc với với 2 hàng và n cột
Xin cảm ơn các bác.
Sau đây là file và code.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Quang86vn đã viết:
Em nhờ các bác xem qua file dữ liệu và code chạy. Ghép chữ theo thứ tự với n (500-1000) hàng, cột thì tùy ý. Hiện tại code chỉ chạy đc với với 2 hàng và n cột
Xin cảm ơn các bác.
Sau đây là file và code.
Nhấp chuột vào đây để mở rộng...
bạn chọn lại vùng đi nhé mình nghĩ là chỗ này bạn đặt 1000 vào thử xem.
Vung = [A1].Resize(1000, iCot)
 
Upvote 0
Các thầy xem giúp em ạ. Cảm ơn các thầy!
 
Upvote 0
Quang86vn đã viết:
Các thầy xem giúp em ạ. Cảm ơn các thầy!
Nhấp chuột vào đây để mở rộng...
Mã: 
Public Sub RoiTung()
Dim Vung, A(), B, I, J, K, Mg, iHang, iCot, idong, m
iCot = Range([A1], [A1].End(xlToRight)).Columns.Count
idong = Range("a" & Rows.Count).End(xlUp).Row
Vung = [A1].Resize(idong, iCot)
ReDim A(1 To idong, 1 To 1)
For I = 1 To UBound(Vung, 2)
    For J = 1 To UBound(Vung, 1)
             A(J, 1) = A(J, 1) & Vung(J, I)
    Next J
Next I
For m = 1 To UBound(A, 1)
iHang = Application.WorksheetFunction.Combin(Len(A(m, 1)), 2)
ReDim Mg(1 To iHang * (m + 2), 1 To idong)
For I = 1 To Len(A(m, 1)) - 1
    For J = I + 1 To Len(A(m, 1))
        K = K + 1
        Mg(K, 1) = Mid(A(m, 1), I, 1) & Mid(A(m, 1), J, 1): Mg(K + idong, 1) = Mid(A(m, 1), J, 1) & Mid(A(m, 1), I, 1)
    Next J
Next I
Sheet1.Range("f1").Offset(0, m).Resize(K * (m + 1), 1).Value = Mg
K = 0
Next m
End Sub
bạn xem có đúng ý bạn không nhé
 
Upvote 0
snow25 đã viết:
Mã: 
Public Sub RoiTung()
Dim Vung, A(), B, I, J, K, Mg, iHang, iCot, idong, m
iCot = Range([A1], [A1].End(xlToRight)).Columns.Count
idong = Range("a" & Rows.Count).End(xlUp).Row
Vung = [A1].Resize(idong, iCot)
ReDim A(1 To idong, 1 To 1)
For I = 1 To UBound(Vung, 2)
    For J = 1 To UBound(Vung, 1)
             A(J, 1) = A(J, 1) & Vung(J, I)
    Next J
Next I
For m = 1 To UBound(A, 1)
iHang = Application.WorksheetFunction.Combin(Len(A(m, 1)), 2)
ReDim Mg(1 To iHang * (m + 2), 1 To idong)
For I = 1 To Len(A(m, 1)) - 1
    For J = I + 1 To Len(A(m, 1))
        K = K + 1
        Mg(K, 1) = Mid(A(m, 1), I, 1) & Mid(A(m, 1), J, 1): Mg(K + idong, 1) = Mid(A(m, 1), J, 1) & Mid(A(m, 1), I, 1)
    Next J
Next I
Sheet1.Range("f1").Offset(0, m).Resize(K * (m + 1), 1).Value = Mg
K = 0
Next m
End Sub
bạn xem có đúng ý bạn không nhé
Nhấp chuột vào đây để mở rộng...
em chạy thử và thấy nó sai và thiếu ký tự ghép nữa bác xem có phải đúng không. cảm ơn bác
 

File đính kèm

Upvote 0
Quang86vn đã viết:
em chạy thử và thấy nó sai và thiếu ký tự ghép nữa bác xem có phải đúng không. cảm ơn bác
Nhấp chuột vào đây để mở rộng...
Mã: 
Public Sub RoiTung()
Dim Vung, A(), B, I, J, K, Mg, iHang, iCot, idong, m
iCot = Range([A1], [A1].End(xlToRight)).Columns.Count
idong = Range("a" & Rows.Count).End(xlUp).Row
Vung = [A1].Resize(idong, iCot)
ReDim A(1 To idong)
For I = 1 To UBound(Vung, 2)
    For J = 1 To UBound(Vung, 1)
             A(J) = A(J) & Vung(J, I)
    Next J
Next I
For m = 1 To UBound(A, 1)
iHang = Application.WorksheetFunction.Combin(Len(A(m)), 2)
ReDim Mg(1 To iHang * 2, 1 To idong)
For I = 1 To Len(A(m)) - 1
    For J = I + 1 To Len(A(m))
        K = K + 1
        Mg(K, 1) = Mid(A(m), I, 1) & Mid(A(m), J, 1): Mg(K + iHang, 1) = Mid(A(m), J, 1) & Mid(A(m), I, 1)
    Next J
Next I
Sheet1.Range("f1").Offset(0, m).Resize(K * 2, 1).Value = Mg
K = 0
Next m
End Sub
đây bạn xem nhé
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
snow25 đã viết:
Mã: 
Public Sub RoiTung()
Dim Vung, A(), B, I, J, K, Mg, iHang, iCot, idong, m
iCot = Range([A1], [A1].End(xlToRight)).Columns.Count
idong = Range("a" & Rows.Count).End(xlUp).Row
Vung = [A1].Resize(idong, iCot)
ReDim A(1 To idong)
For I = 1 To UBound(Vung, 2)
    For J = 1 To UBound(Vung, 1)
             A(J) = A(J) & Vung(J, I)
    Next J
Next I
For m = 1 To UBound(A, 1)
iHang = Application.WorksheetFunction.Combin(Len(A(m)), 2)
ReDim Mg(1 To iHang * 2, 1 To idong)
For I = 1 To Len(A(m)) - 1
    For J = I + 1 To Len(A(m))
        K = K + 1
        Mg(K, 1) = Mid(A(m), I, 1) & Mid(A(m), J, 1): Mg(K + iHang, 1) = Mid(A(m), J, 1) & Mid(A(m), I, 1)
    Next J
Next I
Sheet1.Range("f1").Offset(0, m).Resize(K * 2, 1).Value = Mg
K = 0
Next m
End Sub
đây bạn xem nhé
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác nhiều nhé. Chúc bác và gđ GPE cuối tuần vui vẻ!
 
Upvote 0
Về code chạy đúng nhưng cho lên 600 hàng và 16 ký tự chạy chậm và đợi rất lâu. Các bác các thầy xem có cách nào cải thiện tốc độ xử lý không ạ? Em cảm ơn bác snow25 nhiều!
 
Upvote 0
Quang86vn đã viết:
Về code chạy đúng nhưng cho lên 600 hàng và 16 ký tự chạy chậm và đợi rất lâu. Các bác các thầy xem có cách nào cải thiện tốc độ xử lý không ạ? Em cảm ơn bác snow25 nhiều!
Nhấp chuột vào đây để mở rộng...
Mã: 
Public Sub RoiTung()
Dim Vung, A(), B, I, J, K, Mg, iHang, iCot, idong, m
iCot = Range([A1], [A1].End(xlToRight)).Columns.Count
idong = Range("a" & Rows.Count).End(xlUp).Row
Vung = [A1].Resize(idong, iCot)
ReDim A(1 To idong)
For I = 1 To UBound(Vung, 2)
    For J = 1 To UBound(Vung, 1)
             A(J) = A(J) & Vung(J, I)
    Next J
Next I
iHang = Application.WorksheetFunction.Combin(Len(A(1)), 2)
ReDim Mg(1 To iHang * 2, 1 To idong)
For m = 1 To UBound(A, 1)
For I = 1 To Len(A(m)) - 1
    For J = I + 1 To Len(A(m))
        K = K + 1
        Mg(K, m) = Mid(A(m), I, 1) & Mid(A(m), J, 1): Mg(K + iHang, m) = Mid(A(m), J, 1) & Mid(A(m), I, 1)
    Next J
Next I
K = 0
Next m
Sheet1.Range("p1").Resize(UBound(Mg, 1), idong).Value = Mg
End Sub
bạn dùng code này nhé nhưng mà bắt buộc là số ký tự phải đều nhau.
 
Upvote 0
snow25 đã viết:
Mã: 
Public Sub RoiTung()
Dim Vung, A(), B, I, J, K, Mg, iHang, iCot, idong, m
iCot = Range([A1], [A1].End(xlToRight)).Columns.Count
idong = Range("a" & Rows.Count).End(xlUp).Row
Vung = [A1].Resize(idong, iCot)
ReDim A(1 To idong)
For I = 1 To UBound(Vung, 2)
    For J = 1 To UBound(Vung, 1)
             A(J) = A(J) & Vung(J, I)
    Next J
Next I
iHang = Application.WorksheetFunction.Combin(Len(A(1)), 2)
ReDim Mg(1 To iHang * 2, 1 To idong)
For m = 1 To UBound(A, 1)
For I = 1 To Len(A(m)) - 1
    For J = I + 1 To Len(A(m))
        K = K + 1
        Mg(K, m) = Mid(A(m), I, 1) & Mid(A(m), J, 1): Mg(K + iHang, m) = Mid(A(m), J, 1) & Mid(A(m), I, 1)
    Next J
Next I
K = 0
Next m
Sheet1.Range("p1").Resize(UBound(Mg, 1), idong).Value = Mg
End Sub
bạn dùng code này nhé nhưng mà bắt buộc là số ký tự phải đều nhau.
Nhấp chuột vào đây để mở rộng...
về cơ bản đã ok. Nhưng chạy tối đa đc 220 dòng báo lỗi 09 bác à.
Bài đã được tự động gộp:

befaint đã viết:
https://www.giaiphapexcel.com/diendan/help/terms/
Nhấp chuột vào đây để mở rộng...
Vâng em xin rút kinh nghiệm chưa trích dẫn nguồn. Cảm ơn BQT ạ!
 
Upvote 0
Quang86vn đã viết:
về cơ bản đã ok. Nhưng chạy tối đa đc 220 dòng báo lỗi 09 bác à.
Bài đã được tự động gộp:


Vâng em xin rút kinh nghiệm chưa trích dẫn nguồn. Cảm ơn BQT ạ!
Nhấp chuột vào đây để mở rộng...
không phải là tối đa 220 dòng bạn nhé.chắc là do lỗi khai báo ở cho redim để mình xem lai.
 
Upvote 0
Quang86vn đã viết:
về cơ bản đã ok. Nhưng chạy tối đa đc 220 dòng báo lỗi 09 bác à.
Bài đã được tự động gộp:


Vâng em xin rút kinh nghiệm chưa trích dẫn nguồn. Cảm ơn BQT ạ!
Nhấp chuột vào đây để mở rộng...
đây bạn xem nhé
Mã: 
Public Sub RoiTung1()
Dim Vung, A(), B, I, J, K, Mg, iHang, iCot, idong, m, max As Long
iCot = Range([A1], [A1].End(xlToRight)).Columns.Count
idong = Range("a" & Rows.Count).End(xlUp).Row
Vung = [A1].Resize(idong, iCot)
ReDim A(1 To idong)
For I = 1 To UBound(Vung, 1)
    For J = 1 To UBound(Vung, 2)
             A(I) = A(I) & Vung(I, J)
    Next J
    If max < Len(A(I)) Then max = Len(A(I))
Next I
iHang = Application.WorksheetFunction.Combin(max, 2)
ReDim Mg(1 To iHang * 2, 1 To idong)
For m = 1 To UBound(A, 1)
iHang = Application.WorksheetFunction.Combin(Len(A(m)), 2)
For I = 1 To Len(A(m)) - 1
    For J = I + 1 To Len(A(m))
        K = K + 1
        Mg(K, m) = Mid(A(m), I, 1) & Mid(A(m), J, 1): Mg(K + iHang, m) = Mid(A(m), J, 1) & Mid(A(m), I, 1)
    Next J
Next I
K = 0
Next m
Sheet1.Range("p1").Resize(UBound(Mg, 1), idong).Value = Mg
End Sub
 
Upvote 0
snow25 đã viết:
đây bạn xem nhé
Mã: 
Public Sub RoiTung1()
Dim Vung, A(), B, I, J, K, Mg, iHang, iCot, idong, m, max As Long
iCot = Range([A1], [A1].End(xlToRight)).Columns.Count
idong = Range("a" & Rows.Count).End(xlUp).Row
Vung = [A1].Resize(idong, iCot)
ReDim A(1 To idong)
For I = 1 To UBound(Vung, 1)
    For J = 1 To UBound(Vung, 2)
             A(I) = A(I) & Vung(I, J)
    Next J
    If max < Len(A(I)) Then max = Len(A(I))
Next I
iHang = Application.WorksheetFunction.Combin(max, 2)
ReDim Mg(1 To iHang * 2, 1 To idong)
For m = 1 To UBound(A, 1)
iHang = Application.WorksheetFunction.Combin(Len(A(m)), 2)
For I = 1 To Len(A(m)) - 1
    For J = I + 1 To Len(A(m))
        K = K + 1
        Mg(K, m) = Mid(A(m), I, 1) & Mid(A(m), J, 1): Mg(K + iHang, m) = Mid(A(m), J, 1) & Mid(A(m), I, 1)
    Next J
Next I
K = 0
Next m
Sheet1.Range("p1").Resize(UBound(Mg, 1), idong).Value = Mg
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác nhiều chạy đã ok.
 
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

ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
314
Đọc
23K
jonythanht
J
K
  • Question Question
BÀI TOÁN TÌM GIÁ USD VÀ TÌM LƯỢNG KG - NHỜ ANH/CHỊ GIÚP ĐỠ
    • Chấp nhận
Trả lời
5
Đọc
54
CHAOQUAY
C
Mewwo98
Cách chạy Add-in khi khởi động excel
Trả lời
2
Đọc
13
huhumalu
H
N
Thử viết code lập trình đa luồng bằng TwinBasic và khả năng ứng dụng vào COM add-in chạy trong Excel
    • Thích
Trả lời
3
Đọc
261
nguyendang95
N
K
Mở file Excell lên bị lỗi run-time error 76' path not found
Trả lời
0
Đọc
8
kunkoi9390
K
tuankieu28
Hướng dẫn hàm tìm thông tin
Trả lời
0
Đọc
12
tuankieu28
tuankieu28
A
Kính nhờ xử lý nhập công thức hàm IF kết hợp nhiều điều kiện
Trả lời
1
Đọc
33
thuytrangbp28
T
Momominh
Hỏi công thức tìm kiếm
Trả lời
2
Đọc
31
thuytrangbp28
T
huongmuine
Điền số thứ tự theo nhóm có điều kiện
Trả lời
4
Đọc
57
huongmuine
huongmuine
Mewwo98
Thay dấu ngăn cách sau chữ số hàng nghìn, hàng triệu, hàng tỷ trong Mail Merge
Trả lời
12
Đọc
230
HeSanbi
HeSanbi
H
Nhờ các bạn mở quá công thức của các sheet
Trả lời
3
Đọc
64
VetMini
V
Y
Không copy được dữ liệu sang sheet khac
Trả lời
12
Đọc
24K
leduchien1001
L
S
Lỗi Path/File access error:'.\VBFB.tmp'
Trả lời
10
Đọc
4K
dhtq159
D
N
Vẽ đường tròn bám theo 1 Polyline
Trả lời
4
Đọc
66
nguyenvanvien
N
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
    • Thích
Trả lời
3
Đọc
149
trung_bhxh
T
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
    • Yêu thích
Trả lời
4
Đọc
1K
GPE-Trợ Lý
GPE-Trợ Lý
OverAC
TPHCM - Gặp mặt đầu năm Ất Tỵ 18g ngày 8/2
    • Thích
    • Ngạc nhiên
Trả lời
1
Đọc
97
tungnguyen_kt
tungnguyen_kt
ptm0412
  • Question Question
Cách lấy link file excel nguồn cho Power query từ Onedrive, Google drive
    • Thích
    • Yêu thích
Trả lời
7
Đọc
3K
pxhieu1993
P
Y
Nhờ các anh chị xem giúp Hàm Sumproduct
Trả lời
0
Đọc
39
yoomi
Y
dinhnhat91
  • Question Question
VBA Lỗi runtime error 9 subscript out of range
Trả lời
4
Đọc
113
ongke0711
ongke0711
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
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom