Tách dữ liệu trong 1 sheet ra nhiều Sheet

hadoan-pap · 26/11/20

Em chào mọi người.

Em có 1 file mẫu như đính kèm ạ.

Trong Sheet "Main" em có thông tin 4 loại giao dịch…. em muốn chia từng giao dịch tương ứng ra các Sheet con như trong file ạ.

Rất mong anh chị và các thầy hỗ trợ em code bài toán này ạ.

Em xin chân thành cảm ơn!

befaint · 26/11/20

.. .

PHP:

Option Explicit

Sub vidu()
    Const card_type = "visa"
    Dim data As Variant, res As Variant
    Dim i As Long, ii As Long, j As Long, ub As Long, start_row As Long
    data = Sheet1.Range("A3:C19").Value2
    ub = UBound(data, 1) - 1
    start_row = 2
    ReDim res(1 To ub, 1 To 2)
    For i = ub To start_row Step -1
        If InStr(1, data(i, 2), card_type, vbTextCompare) > 0 Then 'tim thay loai the'
            For j = i - 1 To start_row Step -1
                If Len(data(j, 1)) > 0 Then
                    ii = ii + 1
                    res(ii, 1) = data(j, 2)
                    res(ii, 2) = data(j, 3)
                Else
                    i = j + 1
                    Exit For
                End If
            Next j
        End If
    Next i
    Sheet1.Range("E3").Resize(1000, 2).ClearContents
    If ii > 0 Then Sheet1.Range("E3").Resize(ii, 2).Value = res
End Sub

hadoan-pap · 26/11/20

befaint đã viết:

.. .

PHP:

Option Explicit

Sub vidu()
    Const card_type = "visa"
    Dim data As Variant, res As Variant
    Dim i As Long, ii As Long, j As Long, ub As Long, start_row As Long
    data = Sheet1.Range("A3:C19").Value2
    ub = UBound(data, 1) - 1
    start_row = 2
    ReDim res(1 To ub, 1 To 2)
    For i = ub To start_row Step -1
        If InStr(1, data(i, 2), card_type, vbTextCompare) > 0 Then 'tim thay loai the'
            For j = i - 1 To start_row Step -1
                If Len(data(j, 1)) > 0 Then
                    ii = ii + 1
                    res(ii, 1) = data(j, 2)
                    res(ii, 2) = data(j, 3)
                Else
                    i = j + 1
                    Exit For
                End If
            Next j
        End If
    Next i
    Sheet1.Range("E3").Resize(1000, 2).ClearContents
    If ii > 0 Then Sheet1.Range("E3").Resize(ii, 2).Value = res
End Sub

Dạ, Cảm ơn anh faint rất nhiều ạ.

Chúc anh sk và hp ^^

HieuCD · 26/11/20

hadoan-pap đã viết:
Dạ, Cảm ơn anh faint rất nhiều ạ.

Chúc anh sk và hp ^^

Bạn faint bị bất tỉnh rồi

Hoàng Tuấn 868 · 26/11/20

hadoan-pap đã viết:
Chúc anh sk và hp ^^

......................

hadoan-pap · 26/11/20

Gửi anh @befaint

Dạ em mới tìm được 1 chút khó khan trong đoạn code của anh ạ.

Const card_type = "noi dia" ==> Làm sao để gán địa chỉ của 1 cell vào thay thế cho chữ kia ạ

Vì đang không gõ dc tiếng việt trong code nên em muốn lấy địa chỉ cell để gán vào ạ.

Cảm ơn anh!

Bài đã được tự động gộp: 26/11/20

Dạ em tự xử lý được rồi ạ.

befaint · 26/11/20

hadoan-pap đã viết:
Dạ em mới tìm được 1 chút khó khan trong đoạn code của anh ạ.

Dùng hàm VBA.ChrW$()

Bạn chuyển sub vidu trên thành dạng LocDuLieu(byval ws_target as Worksheet, byval card_type as String) để lọc và ghi dữ liệu vào ws_target

Sub chính như này
Dim noi_dia as string
noi_dia = "n" & ChrW$(7897) & "i " & ChrW$(273) & ChrW$(7883) & "a"
Dim list_cards as variant: list_cards = array(noi_dia, "visa", "mastercard","xyz")
Dim list_ws as variant: list_ws = array(Sheet2, Sheet3, Sheet4, Sheet5)
Dim i as long, num_res as long
num_res = 4
For i=0 to num_res -1
call LocDuLieu(list_ws (i), list_cards (i))
Next i

Nhattanktnn · 26/11/20

hadoan-pap đã viết:
Em chào mọi người.

Em có 1 file mẫu như đính kèm ạ.

Trong Sheet "Main" em có thông tin 4 loại giao dịch…. em muốn chia từng giao dịch tương ứng ra các Sheet con như trong file ạ.

Rất mong anh chị và các thầy hỗ trợ em code bài toán này ạ.

Em xin chân thành cảm ơn!

Chả biết phải vậy không, lỡ làm xong gửi đại

Mã:

Option Explicit
Sub TachSheet()
Dim Ws As Worksheet, Str1 As String, Str2 As String, Rng As Range, I As Long, idRng As Range, The As Range
Dim TypeCard As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Str1 = "T" & ChrW(7893) & "ng giao d" & ChrW(7883) & "ch th" & ChrW(7867)
Str2 = "S" & ChrW(7889) & " ti" & ChrW(7873) & "n GD"
For Each Ws In ActiveWorkbook.Sheets
    If Ws.Name <> "Main" Then Ws.Delete
Next
With Sheets("Main")
    Set Rng = .Range("A4", .Range("A4").SpecialCells(xlLastCell))
    For I = Rng.Rows.Count To 1 Step -1
        If InStr(1, Rng(I, 2).Value, Str1, 1) > 0 Then
            Set The = Rng(I, 2)
            TypeCard = Trim(Replace(Replace(Rng(I, 2), Str1, ""), ":", ""))
            Do While Rng(I - 1, 1) <> "" And I > 1
                If idRng Is Nothing Then
                    Set idRng = Rng(I - 1, 1)
                Else
                    Set idRng = Union(idRng, Rng(I - 1, 1))
                End If
                    I = I - 1
            Loop
            Worksheets.Add after:=Sheets("Main")
            Set Ws = ActiveSheet
            With Ws
                .Name = TypeCard
                .Cells(1, 1) = The.Value
                .Cells(1, 2) = Str2
                idRng.Offset(, 1).Resize(, 2).Copy .Range("A2")
                .Columns("A:B").AutoFit
            End With
        End If
        Set The = Nothing: Set idRng = Nothing
    Next
    .Activate
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

hadoan-pap · 26/11/20

befaint đã viết:
Dùng hàm VBA.ChrW$()

Bạn chuyển sub vidu trên thành dạng LocDuLieu(byval ws_target as Worksheet, byval card_type as String) để lọc và ghi dữ liệu vào ws_target

Sub chính như này
Dim noi_dia as string
noi_dia = "n" & ChrW$(7897) & "i " & ChrW$(273) & ChrW$(7883) & "a"
Dim list_cards as variant: list_cards = array(noi_dia, "visa", "mastercard","xyz")
Dim list_ws as variant: list_ws = array(Sheet2, Sheet3, Sheet4, Sheet5)
Dim i as long, num_res as long
num_res = 4
For i=0 to num_res -1
call LocDuLieu(list_ws (i), list_cards (i))
Next i

Gửi anh.

Anh ơi em hơi tù mù phần xử lý này ạ... phiền anh có thể code lại giúp để em study mẫu được không anh?

Em muốn xử lý cho trường hợp Card_Type có mấy loại liền một lúc như anh bảo anh, mỗi loại sẽ xử lý ghi data vào 1 sheet riêng ( Sheet2,3,4,5 )
Em cảm ơn anh nhiều ạ.

Bài đã được tự động gộp: 26/11/20

Nhattanktnn đã viết:

Chả biết phải vậy không, lỡ làm xong gửi đại

Mã:

Option Explicit
Sub TachSheet()
Dim Ws As Worksheet, Str1 As String, Str2 As String, Rng As Range, I As Long, idRng As Range, The As Range
Dim TypeCard As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Str1 = "T" & ChrW(7893) & "ng giao d" & ChrW(7883) & "ch th" & ChrW(7867)
Str2 = "S" & ChrW(7889) & " ti" & ChrW(7873) & "n GD"
For Each Ws In ActiveWorkbook.Sheets
    If Ws.Name <> "Main" Then Ws.Delete
Next
With Sheets("Main")
    Set Rng = .Range("A4", .Range("A4").SpecialCells(xlLastCell))
    For I = Rng.Rows.Count To 1 Step -1
        If InStr(1, Rng(I, 2).Value, Str1, 1) > 0 Then
            Set The = Rng(I, 2)
            TypeCard = Trim(Replace(Replace(Rng(I, 2), Str1, ""), ":", ""))
            I = I - 1
            Do While Rng(I, 1) <> ""
                If idRng Is Nothing Then
                    Set idRng = Rng(I, 1)
                Else
                    Set idRng = Union(idRng, Rng(I, 1))
                End If
                    I = I - 1
            Loop
            Worksheets.Add after:=Sheets("Main")
            Set Ws = ActiveSheet
            With Ws
                .Name = TypeCard
                .Cells(1, 1) = The.Value
                .Cells(1, 2) = Str2
                idRng.Offset(, 1).Resize(, 2).Copy .Range("A2")
                .Columns("A:B").AutoFit
            End With
        End If
        Set The = Nothing: Set idRng = Nothing
    Next
    .Activate
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Cảm ơn anh nhiều ạ

Nhattanktnn · 26/11/20

hadoan-pap đã viết:
Cảm ơn anh nhiều ạ

Chưa đúng đâu

, rảnh mình xem lại

hadoan-pap · 26/11/20

Nhattanktnn đã viết:
Chưa đúng đâu , rảnh mình xem lại

Anh cho em hỏi chút….

Sheet "Main" nếu cột C nó di chuyển sang cột E.... thì để lấy đúng số tiền ở cột E ở Sheet "Main" để đưa sang cột B ở các sheet kia thì đổi code ở chỗ nào ạ ?

Nhattanktnn · 26/11/20

Bài #8 đã sửa lại, bạn kiểm tra lại xem

hadoan-pap đã viết:
Anh cho em hỏi chút….

Sheet "Main" nếu cột C nó di chuyển sang cột E.... thì để lấy đúng số tiền ở cột E ở Sheet "Main" để đưa sang cột B ở các sheet kia thì đổi code ở chỗ nào ạ ?

Chắc copy hết dữ liệu đưa qua, xong xóa cột không cần ở sheet mới, nó sẽ về lại cột B

hadoan-pap · 26/11/20

Nhattanktnn đã viết:
Bài #8 đã sửa lại, bạn kiểm tra lại xem

Chắc copy hết dữ liệu đưa qua, xong xóa cột không cần ở sheet mới, nó sẽ về lại cột B

Chắc làm thế cho nhanh vậy

Cảm ơn anh nhé!

Nhattanktnn · 26/11/20

hadoan-pap đã viết:
Chắc làm thế cho nhanh vậy

Ý là không phải làm tay, mà sửa code đoạn này:
.Cells(1, 4) = Str2
idRng.Offset(, 1).Resize(, 4).Copy .Range("A2")
.Columns("B:C").Delete

Bài đã được tự động gộp: 26/11/20

Lưu ý là nếu chỗ tiền ở cột E có tham chiếu đến cột C, D thì như vậy sẽ bị sai nha

Tách dữ liệu trong 1 sheet ra nhiều Sheet

hadoan-pap

Thành viên tiêu biểu

File đính kèm

befaint

|||||||||||||

hadoan-pap

Thành viên tiêu biểu

HieuCD

Chuyên gia GPE

Hoàng Tuấn 868

Đăng ký hôm qua

hadoan-pap

Thành viên tiêu biểu

befaint

|||||||||||||

Nhattanktnn

Thành viên gắn bó

hadoan-pap

Thành viên tiêu biểu

Nhattanktnn

Thành viên gắn bó

hadoan-pap

Thành viên tiêu biểu

Nhattanktnn

Thành viên gắn bó

hadoan-pap

Thành viên tiêu biểu

Nhattanktnn

Thành viên gắn bó

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