Ghép số

sep_hatxel · 3/11/10

Chào GPE!
GPE có thể giúp mình cách ghép biến số từ một cột xuất sang cột khác trên excel 2003 hoặc 2007 với! Mình xin gửi kèm theo file có minh hoạ! Thân ái!

ChanhTQ@ · 4/11/10

Chúc buổi sáng tốt lành!

PHP:

Option Explicit
Sub GhépSó()
 Dim jJ As Long, eRw As Long, Ww As Long
 Const PC As String = "-"
 
 eRw = [A65500].End(xlUp).Row
 [B2].CurrentRegion.Offset(1, 1).ClearContents
 For jJ = 2 To eRw - 1
   For Ww = jJ + 1 To eRw
      With [b65500].End(xlUp).Offset(1)
         .Value = Cells(jJ, "A").Value & PC & Cells(Ww, "A").Value
      End With
 Next Ww, jJ
 For jJ = 3 To eRw
   For Ww = 2 To jJ - 1
      With [c65500].End(xlUp).Offset(1)
         .Value = Cells(jJ, "A").Value & PC & Cells(Ww, "A").Value
      End With
 Next Ww, jJ
End Sub

sep_hatxel · 4/11/10

ChanhTQ@ đã viết:

PHP:

Option Explicit
Sub GhépSó()
Dim jJ As Long, eRw As Long, Ww As Long
Const PC As String = "-"
 
eRw = [A65500].End(xlUp).Row
[B2].CurrentRegion.Offset(1, 1).ClearContents
For jJ = 2 To eRw - 1
For Ww = jJ + 1 To eRw
With [b65500].End(xlUp).Offset(1)
.Value = Cells(jJ, "A").Value & PC & Cells(Ww, "A").Value
End With
Next Ww, jJ
For jJ = 3 To eRw
For Ww = 2 To jJ - 1
With [c65500].End(xlUp).Offset(1)
.Value = Cells(jJ, "A").Value & PC & Cells(Ww, "A").Value
End With
Next Ww, jJ
End Sub

Vâng! Cảm ơn Bác ChanhTQ@ rất nhiều! Chúc Ngày mới thắng lợi với toàn thể GPE!
Bác ChanhTQ ơi! Phần ghép số xuất sang cột B đúng rồi bác ạh! Nhưng xuất sang cột C thì thứ tự bị đảo lộn do định dạng vị trí thứ tự của excel! Mình có thể làm vị trí của cột C giống như ở cột B với vị trí tương ứng, ví dụ như: cột C: X1-X2 tương ứng cùng hàng Cột C là: X2-X1 được không ạ?
Chân thành cảm ơn bác ChanhTQ@ rất nhiều!

concogia · 4/11/10

sep_hatxel đã viết:
Vâng! Cảm ơn Bác ChanhTQ@ rất nhiều! Chúc Ngày mới thắng lợi với toàn thể GPE!
Bác ChanhTQ ơi! Phần ghép số xuất sang cột B đúng rồi bác ạh! Nhưng xuất sang cột C thì thứ tự bị đảo lộn do định dạng vị trí thứ tự của excel! Mình có thể làm vị trí của cột C giống như ở cột B với vị trí tương ứng, ví dụ như: cột C: X1-X2 tương ứng cùng hàng Cột C là: X2-X1 được không ạ?
Chân thành cảm ơn bác ChanhTQ@ rất nhiều!

Thử với cái này xem sao

Mã:

Public Sub chay()
    Dim MgA(), MgB(), I As Long, J As Long, K As Long, Ij As Long
    [a4].CurrentRegion.Offset(, 1).Clear
        MgA = Range([a4], [a1000].End(xlUp)).Value
        K = Application.WorksheetFunction.Combin(UBound(MgA), 2)
            ReDim MgB(1 To K, 1 To 2):            J = 1
                For Ij = 1 To UBound(MgA) - 1
                    For I = Ij + 1 To UBound(MgA)
                        MgB(J, 1) = MgA(Ij, 1) & " -" & MgA(I, 1)
                        MgB(J, 2) = MgA(I, 1) & " -" & MgA(Ij, 1)
                        J = J + 1
                    Next I
                Next Ij
    [b4].Resize(K, 2) = MgB
End Sub

ThuNghi · 4/11/10

sep_hatxel đã viết:
Chào GPE!
GPE có thể giúp mình cách ghép biến số từ một cột xuất sang cột khác trên excel 2003 hoặc 2007 với! Mình xin gửi kèm theo file có minh hoạ! Thân ái!

Bài này cũng giống bài trước đó mà, còn dễ hơn.
Hỏi thật cái này ứng dụng vài việc gì vậy.
Dùng thử code sau. Có thể thay .Range("A" & FRow).Offset(, 3).Resize(s, 2) = ArrKQ thành 1 hay i

PHP:

Sub GhepSo()
Const FRow = 4
Dim Arr(), ArrKQ()
Dim endR As Long, i As Long, j As Long, s As Long, k As Long
With Sheet1
  endR = .Cells(65000, 1).End(xlUp).Row - FRow + 1
  Arr = .Range("A" & FRow).Resize(endR, 1).Value
End With
endR = UBound(Arr, 1)
If endR * endR > 65000 Then k = 65000
ReDim ArrKQ(1 To k, 1 To 2): s = 0
For i = 1 To endR - 1
  For j = i + 1 To endR
    s = s + 1
    ArrKQ(s, 1) = Arr(i, 1) & "-" & Arr(j, 1)
    ArrKQ(s, 2) = Arr(j, 1) & "-" & Arr(i, 1)
    If s > 65000 - 1 Then GoTo Exit_Sub
  Next j
Next i
Exit_Sub:
With Sheet1
  .Range("A" & FRow).Offset(, 3).Resize(s, 2) = ArrKQ
End With
Erase Arr(), ArrKQ()
End Sub

ndu96081631 · 4/11/10

Làm 1 sub có tham số truyền cho nó tổng quát

PHP:

Sub Combin(sArr, Target As Range)
  Dim TmpArr, Arr(), i As Long, j As Long, n As Long
  TmpArr = sArr
  For i = LBound(TmpArr) To UBound(TmpArr) - 1
    For j = i + 1 To UBound(TmpArr)
      n = n + 1
      ReDim Preserve Arr(1 To 2, 1 To n)
      Arr(1, n) = TmpArr(i) & "-" & TmpArr(j)
      Arr(2, n) = TmpArr(j) & "-" & TmpArr(i)
    Next
  Next
  Target.Resize(n, 2) = WorksheetFunction.Transpose(Arr)
End Sub

Muốn chạy tại vùng nào, đặt kết quả vào đâu thì cứ khai báo ở sub dưới đây:

PHP:

Sub Main()
  Dim sArr, Target As Range
  sArr = WorksheetFunction.Transpose([A4:A22])
  Set Target = [B4]
  Combin sArr, Target
End Sub

sep_hatxel · 5/11/10

Cảm ơn GPE! Cảm ơn các bạn! kiến thức thật phong phú - GPE đã giúp cho mình rất nhiều! Một ngày mới tươi sáng!

sep_hatxel · 17/12/10

ThuNghi đã viết:
Bài này cũng giống bài trước đó mà, còn dễ hơn.
Hỏi thật cái này ứng dụng vài việc gì vậy.
Dùng thử code sau. Có thể thay .Range("A" & FRow).Offset(, 3).Resize(s, 2) = ArrKQ thành 1 hay i

PHP:

Sub GhepSo() Const FRow = 4 Dim Arr(), ArrKQ() Dim endR As Long, i As Long, j As Long, s As Long, k As Long With Sheet1 endR = .Cells(65000, 1).End(xlUp).Row - FRow + 1 Arr = .Range("A" & FRow).Resize(endR, 1).Value End With endR = UBound(Arr, 1) If endR * endR > 65000 Then k = 65000 ReDim ArrKQ(1 To k, 1 To 2): s = 0 For i = 1 To endR - 1 For j = i + 1 To endR s = s + 1 ArrKQ(s, 1) = Arr(i, 1) & "-" & Arr(j, 1) ArrKQ(s, 2) = Arr(j, 1) & "-" & Arr(i, 1) If s > 65000 - 1 Then GoTo Exit_Sub Next j Next i Exit_Sub: With Sheet1 .Range("A" & FRow).Offset(, 3).Resize(s, 2) = ArrKQ End With Erase Arr(), ArrKQ() End Sub

Bạn ơi! Mình đang vướng mắc đoạn code này? Nếu kết quả nối với nhau bởi dấu "-" thì sẽ định dạng theo kiểu ngày tháng! Gặp trường hợp, ví dụ: số 5 ghép với số 0 chẳng hạn thì kết quả không còn đúng nữa! Chân thành nhờ bạn có thể sửa lại đoạn code sao cho cách ghép vẫn như vậy nhưng kết quả thành số luôn, ví dụ: 1 ghép với 0 thì kết quả là 10; 0 ghép với 0 thì kết quả là 0 (nếu là 00 thì càng đẹp); 0 ghép với 2 thì kết quả là 2 (nếu là 02 càng đẹp); .v.v... Mình xin gửi kèm theo file! Chân thành cảm ơn!

ndu96081631 · 17/12/10

sep_hatxel đã viết:
Bạn ơi! Mình đang vướng mắc đoạn code này? Nếu kết quả nối với nhau bởi dấu "-" thì sẽ định dạng theo kiểu ngày tháng! Gặp trường hợp, ví dụ: số 5 ghép với số 0 chẳng hạn thì kết quả không còn đúng nữa! Chân thành nhờ bạn có thể sửa lại đoạn code sao cho cách ghép vẫn như vậy nhưng kết quả thành số luôn, ví dụ: 1 ghép với 0 thì kết quả là 10; 0 ghép với 0 thì kết quả là 0 (nếu là 00 thì càng đẹp); 0 ghép với 2 thì kết quả là 2 (nếu là 02 càng đẹp); .v.v... Mình xin gửi kèm theo file! Chân thành cảm ơn!

Code tôi đưa ở trên, chỉ sửa lại tí là đúng yêu cầu rồi:

PHP:

Sub Combin(sArr, Target As Range)
  Dim TmpArr, Arr(), i As Long, j As Long, n As Long
  TmpArr = sArr
  For i = LBound(TmpArr) To UBound(TmpArr) - 1
    For j = i + 1 To UBound(TmpArr)
      n = n + 1
      ReDim Preserve Arr(1 To 2, 1 To n)
      Arr(1, n) = "'" & TmpArr(i) & TmpArr(j)
      Arr(2, n) = "'" & TmpArr(j) & TmpArr(i)
    Next
  Next
  Target.Resize(n, 2) = WorksheetFunction.Transpose(Arr)
End Sub

PHP:

Sub Main()
  Dim sArr, Target As Range
  sArr = WorksheetFunction.Transpose([E4:E9])
  Set Target = [F4]
  Combin sArr, Target
End Sub

Thậm chí, muốn thêm dấu "-" vào cũng chẳng sao (vì tôi đã cố tình "ép" nó thành TEXT rồi)
ví dụ thế này:

PHP:

Sub Combin(sArr, Target As Range)
  Dim TmpArr, Arr(), i As Long, j As Long, n As Long
  TmpArr = sArr
  For i = LBound(TmpArr) To UBound(TmpArr) - 1
    For j = i + 1 To UBound(TmpArr)
      n = n + 1
      ReDim Preserve Arr(1 To 2, 1 To n)
      Arr(1, n) = "'" & TmpArr(i) & "-" & TmpArr(j)
      Arr(2, n) = "'" & TmpArr(j) & "-" & TmpArr(i)
    Next
  Next
  Target.Resize(n, 2) = WorksheetFunction.Transpose(Arr)
End Sub

sep_hatxel · 17/12/10

ndu96081631 đã viết:

Code tôi đưa ở trên, chỉ sửa lại tí là đúng yêu cầu rồi:

PHP:

Sub Combin(sArr, Target As Range)
Dim TmpArr, Arr(), i As Long, j As Long, n As Long
TmpArr = sArr
For i = LBound(TmpArr) To UBound(TmpArr) - 1
For j = i + 1 To UBound(TmpArr)
n = n + 1
ReDim Preserve Arr(1 To 2, 1 To n)
Arr(1, n) = "'" & TmpArr(i) & TmpArr(j)
Arr(2, n) = "'" & TmpArr(j) & TmpArr(i)
Next
Next
Target.Resize(n, 2) = WorksheetFunction.Transpose(Arr)
End Sub

PHP:

Sub Main()
Dim sArr, Target As Range
sArr = WorksheetFunction.Transpose([E4:E9])
Set Target = [F4]
Combin sArr, Target
End Sub

Thậm chí, muốn thêm dấu "-" vào cũng chẳng sao (vì tôi đã cố tình "ép" nó thành TEXT rồi)
ví dụ thế này:

PHP:

Sub Combin(sArr, Target As Range)
Dim TmpArr, Arr(), i As Long, j As Long, n As Long
TmpArr = sArr
For i = LBound(TmpArr) To UBound(TmpArr) - 1
For j = i + 1 To UBound(TmpArr)
n = n + 1
ReDim Preserve Arr(1 To 2, 1 To n)
Arr(1, n) = "'" & TmpArr(i) & "-" & TmpArr(j)
Arr(2, n) = "'" & TmpArr(j) & "-" & TmpArr(i)
Next
Next
Target.Resize(n, 2) = WorksheetFunction.Transpose(Arr)
End Sub

Tuyệt vời bạn àh! Cám ơn bạn nhiều quá! Cảm ơn GPE!
Bạn ơi! Với dữ liệu nhập ít thì rất ok! Nhưng với dữ liệu nhiều thì mình thấy báo lỗi thời gian chạy: "Run time error '13', Type mismatch". Ví dụ mình nhập số liệu cho vùng ([E4:E1203]) và đã sửa ở đoạn code như vậy và thấy thông báo như trên? Bạn xem giúp mình nhé! Cảm ơn!

ndu96081631 · 18/12/10

sep_hatxel đã viết:
Tuyệt vời bạn àh! Cám ơn bạn nhiều quá! Cảm ơn GPE!
Bạn ơi! Với dữ liệu nhập ít thì rất ok! Nhưng với dữ liệu nhiều thì mình thấy báo lỗi thời gian chạy: "Run time error '13', Type mismatch". Ví dụ mình nhập số liệu cho vùng ([E4:E1203]) và đã sửa ở đoạn code như vậy và thấy thông báo như trên? Bạn xem giúp mình nhé! Cảm ơn!

Với dữ liệu lớn thì lỗi xuất hiện là do hàm TRANSPOSE gây ra! Giờ sửa lại (không dùng hàm TRANSPOSE)

PHP:

Sub Combin(ByVal sRng As Range, ByVal Target As Range)
  Dim TmpArr, Arr(), iR As Long, i As Long, j As Long, n As Long
  On Error GoTo ExitSub
  TmpArr = sRng.Value
  iR = sRng.Rows.Count
  ReDim Arr(1 To (iR - 1) * iR / 2, 1 To 2)
  For i = 1 To iR - 1
    For j = i + 1 To iR
      n = n + 1
      Arr(n, 1) = "'" & TmpArr(i, 1) & TmpArr(j, 1)
      Arr(n, 2) = "'" & TmpArr(j, 1) & TmpArr(i, 1)
    Next
  Next
  Target.Resize(n, 2) = Arr
ExitSub:
End Sub

PHP:

Sub Main()
  Dim sRng, Target As Range
  Set sRng = [E4:E1203]
  Set Target = [F4]
  Target.Resize(100000, 2).Clear
  Combin sRng, Target
End Sub

Với code này bạn phải bảo đảm rằng dữ liệu được bố trí theo chiều dọc (tức 1 dòng nhiều cột)

sep_hatxel · 18/12/10

ndu96081631 đã viết:
Với dữ liệu lớn thì lỗi xuất hiện là do hàm TRANSPOSE gây ra! Giờ sửa lại (không dùng hàm TRANSPOSE)

PHP:

Sub Combin(ByVal sRng As Range, ByVal Target As Range) Dim TmpArr, Arr(), iR As Long, i As Long, j As Long, n As Long On Error GoTo ExitSub TmpArr = sRng.Value iR = sRng.Rows.Count ReDim Arr(1 To (iR - 1) * iR / 2, 1 To 2) For i = 1 To iR - 1 For j = i + 1 To iR n = n + 1 Arr(n, 1) = "'" & TmpArr(i, 1) & TmpArr(j, 1) Arr(n, 2) = "'" & TmpArr(j, 1) & TmpArr(i, 1) Next Next Target.Resize(n, 2) = Arr ExitSub: End Sub

PHP:

Sub Main() Dim sRng, Target As Range Set sRng = [E4:E1203] Set Target = [F4] Target.Resize(100000, 2).Clear Combin sRng, Target End Sub

Với code này bạn phải bảo đảm rằng dữ liệu được bố trí theo chiều dọc (tức 1 dòng nhiều cột)

Vâng! Hay quá bạn à, đúng như ý của mình! Cảm ơn bạn rất nhiều! Chúc bạn nhiều may mắn! Cảm ơn GPE!

thanhnguyencfg · 29/9/21

ndu96081631 đã viết:
Làm 1 sub có tham số truyền cho nó tổng quát

PHP:

Sub Combin(sArr, Target As Range) Dim TmpArr, Arr(), i As Long, j As Long, n As Long TmpArr = sArr For i = LBound(TmpArr) To UBound(TmpArr) - 1 For j = i + 1 To UBound(TmpArr) n = n + 1 ReDim Preserve Arr(1 To 2, 1 To n) Arr(1, n) = TmpArr(i) & "-" & TmpArr(j) Arr(2, n) = TmpArr(j) & "-" & TmpArr(i) Next Next Target.Resize(n, 2) = WorksheetFunction.Transpose(Arr) End Sub

Muốn chạy tại vùng nào, đặt kết quả vào đâu thì cứ khai báo ở sub dưới đây:

PHP:

Sub Main() Dim sArr, Target As Range sArr = WorksheetFunction.Transpose([A4:A22]) Set Target = [B4] Combin sArr, Target End Sub

Em cũng bị tương tư khi chạy userform (tìm kiếm) nhờ sư phụ xử lý giúp em với!
em có file đính kèm

Ghép số

sep_hatxel

Thành viên thường trực

File đính kèm

ChanhTQ@

0901452không62

sep_hatxel

Thành viên thường trực

concogia

Gội rồi mới Cạo

File đính kèm

ThuNghi

Hãy cho rồi sẽ nhận!

ndu96081631

Huyền thoại GPE

sep_hatxel

Thành viên thường trực

sep_hatxel

Thành viên thường trực

File đính kèm

ndu96081631

Huyền thoại GPE

File đính kèm

sep_hatxel

Thành viên thường trực

ndu96081631

Huyền thoại GPE

File đính kèm

sep_hatxel

Thành viên thường trực

thanhnguyencfg

Thành viên mới

File đính kèm

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

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