Giúp sửa code lọc 1 chuỗi sang 1 bảng dữ liệu (1 người xem)

minhtuan55 · 21/2/17

Chào cả nhà GPE !
Mình có dùng 1 đoạn code ( cũng ở trên diễn đàn ) dùng để Tách chuổi từ 1 ô sang 1 vùng bảng dữ liệu

Mã:

Sub Tach()Dim Arr(1 To 1000, 1 To 4), Tmp, Tem, Str As String
Dim I As Long, J As Long, K As Long, C As Long, Col As Long
Str = Range("a5").Value  ' input
Tmp = Split(Str, ";"): C = UBound(Tmp): K = 1
On Error Resume Next
For I = 0 To C
    Tem = Split(Tmp(I), "*"): Col = 1
    For J = 0 To 3
        Arr(K, Col) = Tem(J)
        Col = Col + 1
    Next J
    If Col > 4 Then
        Col = 1: K = K + 1
    End If
Next I
Range("i5").Resize(K, 4) = Arr 'output
End Sub

Ở code trên chỉ tách từ 1 ô A5, giờ mình tách từ A5:A22 thì sữa code ra làm sao. Kinh mong các bạn giúp đở. Mình xin chân thành cảm ơn, Chúc buổi tối vui vẽ

ndu96081631 · 21/2/17

minhtuan55 đã viết:
Chào cả nhà GPE !
Mình có dùng 1 đoạn code ( cũng ở trên diễn đàn ) dùng để Tách chuổi từ 1 ô sang 1 vùng bảng dữ liệu

Mã:

Sub Tach()Dim Arr(1 To 1000, 1 To 4), Tmp, Tem, Str As String Dim I As Long, J As Long, K As Long, C As Long, Col As Long Str = Range("a5").Value ' input Tmp = Split(Str, ";"): C = UBound(Tmp): K = 1 On Error Resume Next For I = 0 To C Tem = Split(Tmp(I), "*"): Col = 1 For J = 0 To 3 Arr(K, Col) = Tem(J) Col = Col + 1 Next J If Col > 4 Then Col = 1: K = K + 1 End If Next I Range("i5").Resize(K, 4) = Arr 'output End Sub

Ở code trên chỉ tách từ 1 ô A5, giờ mình tách từ A5:A22 thì sữa code ra làm sao. Kinh mong các bạn giúp đở. Mình xin chân thành cảm ơn, Chúc buổi tối vui vẽ

Thử code vầy xem sao:

Mã:

Private Sub Transpose2Table(ByVal RangeSource As Range, ByVal Target As Range)
  Dim sTmp As String, objClb As Object
  RangeSource.Copy
  Set objClb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  objClb.GetFromClipboard
  sTmp = objClb.GetText
  If Len(sTmp) >2 Then
    sTmp = Replace(sTmp, "*", vbTab)
    sTmp = Replace(sTmp, ";", vbCrLf)
    sTmp = Replace(sTmp, vbCrLf & vbCrLf, vbCrLf)
    objClb.Clear
    objClb.SetText sTmp
    objClb.PutInClipboard
    Target.PasteSpecial
  End If
End Sub
Sub Main()
  Transpose2Table [COLOR=#ff0000]Range("A5:A22"), Range("I5")[/COLOR]
End Sub

Bạn chỉ cần quan tâm đoạn màu đỏ:
Range("A5:A22") : là vùng chứa chuỗi
Range("I5") : là nơi cần tạo bảng
Muốn tùy biến cứ sửa 2 chỗ này là được rồi
---------------------------
Code viết đại, hên thì trúng (trật thì... thôi --=0

)

minhtuan55 · 21/2/17

Em thử rồi anh ơi. Phải nói là quá tuyệt vời. Hở ai mà viết code mà chừa cái đầu vào và cái đầu ra để em tự thay đổi là em khoái lắm. Cảm ơn anh nhiều lắm....
p/s: Set objClb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") chổ này chắc 10 năm nữa em mới hiểu haha

ndu96081631 đã viết:
Thử code vầy xem sao:

Mã:

Private Sub Transpose2Table(ByVal RangeSource As Range, ByVal Target As Range) Dim sTmp As String, objClb As Object RangeSource.Copy Set objClb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objClb.GetFromClipboard sTmp = objClb.GetText If Len(sTmp) >2 Then sTmp = Replace(sTmp, "*", vbTab) sTmp = Replace(sTmp, ";", vbCrLf) sTmp = Replace(sTmp, vbCrLf & vbCrLf, vbCrLf) objClb.Clear objClb.SetText sTmp objClb.PutInClipboard Target.PasteSpecial End If End Sub Sub Main() Transpose2Table [COLOR=#ff0000]Range("A5:A22"), Range("I5")[/COLOR] End Sub

Bạn chỉ cần quan tâm đoạn màu đỏ:
Range("A5:A22") : là vùng chứa chuỗi
Range("I5") : là nơi cần tạo bảng
Muốn tùy biến cứ sửa 2 chỗ này là được rồi
---------------------------
Code viết đại, hên thì trúng (trật thì... thôi )

ndu96081631 · 21/2/17

minhtuan55 đã viết:
p/s: Set objClb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") chổ này chắc 10 năm nữa em mới hiểu haha

Cái đó là Clipboard (copy gì đó rồi vào trong clipboard rồi xào nấu lạ. Xào xong dọn ra.. ăn )
Ai biết đâu, thấy người ta làm rồi bắt chước, tôi cũng đâu có hiểu gì --=0

minhtuan55 · 21/2/17

ndu96081631 đã viết:
Cái đó là Clipboard (copy gì đó rồi vào trong clipboard rồi xào nấu lạ. Xào xong dọn ra.. ăn )
Ai biết đâu, thấy người ta làm rồi bắt chước, tôi cũng đâu có hiểu gì

Ak anh ơi. Em muốn sau khi Code chạy xong sẽ tự Clear clipboard luôn. Hình như code nó lưu luôn vào bộ nhớ Clipboard Vì nhiều khi e lở tay Ctrl + V thì nó Paste vào dữ liệu của em. Mong anh giúp em trọn gói

ndu96081631 · 21/2/17

minhtuan55 đã viết:
Ak anh ơi. Em muốn sau khi Code chạy xong sẽ tự Clear clipboard luôn. Hình như code nó lưu luôn vào bộ nhớ Clipboard Vì nhiều khi e lở tay Ctrl + V thì nó Paste vào dữ liệu của em. Mong anh giúp em trọn gói

Tạm sửa vầy:

Mã:

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Sub ClearClipboard()
    OpenClipboard (0&)
    EmptyClipboard
    CloseClipboard
End Sub
Private Sub Transpose2Table(ByVal RangeSource As Range, ByVal Target As Range)
  Dim sTmp As String, objClb As Object
  RangeSource.Copy
  Set objClb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  objClb.GetFromClipboard
  sTmp = objClb.GetText
  If Len(sTmp) > 2 Then
    sTmp = Replace(sTmp, "*", vbTab)
    sTmp = Replace(sTmp, ";", vbCrLf)
    sTmp = Replace(sTmp, vbCrLf & vbCrLf, vbCrLf)
    objClb.Clear
    objClb.SetText sTmp
    objClb.PutInClipboard
    Target.PasteSpecial
    ClearClipboard
  End If
End Sub
Sub Main()
  Transpose2Table Range("A5:A22"), Range("I5")
End Sub

minhtuan55 · 22/2/17

ndu96081631 đã viết:

Tạm sửa vầy:

Mã:

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Sub ClearClipboard()
    OpenClipboard (0&)
    EmptyClipboard
    CloseClipboard
End Sub
Private Sub Transpose2Table(ByVal RangeSource As Range, ByVal Target As Range)
  Dim sTmp As String, objClb As Object
  RangeSource.Copy
  Set objClb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  objClb.GetFromClipboard
  sTmp = objClb.GetText
  If Len(sTmp) > 2 Then
    sTmp = Replace(sTmp, "*", vbTab)
    sTmp = Replace(sTmp, ";", vbCrLf)
    sTmp = Replace(sTmp, vbCrLf & vbCrLf, vbCrLf)
    objClb.Clear
    objClb.SetText sTmp
    objClb.PutInClipboard
    Target.PasteSpecial
    ClearClipboard
  End If
End Sub
Sub Main()
  Transpose2Table Range("A5:A22"), Range("I5")
End Sub

Thank anh. Chúc anh 1 ngày vui vẽ

VetMini · 22/2/17

ndu96081631 đã viết:
Cái đó là Clipboard (copy gì đó rồi vào trong clipboard rồi xào nấu lạ. Xào xong dọn ra.. ăn )
Ai biết đâu, thấy người ta làm rồi bắt chước, tôi cũng đâu có hiểu gì

Cái đó khong hẳn là clipboard. Chính thức nó là cái DataObject của Microsoft Forms 2.0
Cái DataObject này có những phương thức đọc text và ghi text vào clipboard cho nên có thể dùng để làm việc với clipboard.

Những cái COM bình thường như Scripting.FileSystemObject có ghi tên trong registry cho nên ta có thể đưa tên vào hàm CreateObject để lập đối tượng một cách dễ dàng.
Với những cái COM khong có tên trong registry thì ta phải nạp thêm cho CreateObject lệnh new và cái ClassID.
Trong trường hợp này, ClassID của DataObject là 1C3B4210-F441-11CE-B9EA-00AA006B1A69

Giúp sửa code lọc 1 chuỗi sang 1 bảng dữ liệu (1 người xem)

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

minhtuan55

Thành viên bị đình chỉ hoạt động

File đính kèm

ndu96081631

Huyền thoại GPE

minhtuan55

Thành viên bị đình chỉ hoạt động

ndu96081631

Huyền thoại GPE

minhtuan55

Thành viên bị đình chỉ hoạt động

ndu96081631

Huyền thoại GPE

minhtuan55

Thành viên bị đình chỉ hoạt động

VetMini

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

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

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