[Help] VBA tìm đến tên cột Team in charge

ngoctuyen1995 · 30/11/18

Thân chào cả Nhà GPEX.!

Tình hình là Em có nghiên cứu và tìm hiểu một đoạn code trên mạng về Tách sheet, Thấy hay download về sửa lại theo ý mình, nhưng hiện tại em có một chỗ không biết giải quyết thế nào, mong cả nhà giúp đỡ em ạ..

Theo đoạn code "Tach sheet" (File đính kèm) thì nó đang tìm đến vị trí cột cố định là cột S2 và đoạn AutoFilter Field:=19 (như hình bên dưới) làm điều kiện để tách sheet.... vì em muốn ứng dụng cho nhiều dự án, nên thay vì tìm đến cột cố định thì em muốn tìm đến Hàng A1 và cột có tên là "Team in charge" như vậy sẽ linh động hơn ạ..

Mong cả nhà giúp đỡ ạ..
Em chân thành cảm ơn..

befaint · 30/11/18

ngoctuyen1995 đã viết:
Hàng A1

A1 là một ô (cell) duy nhất, nên luôn luôn và luôn luôn gọi nó là ô.
Ví dụ: Ô A1, ô B2, ô G5

Không bao giờ và không bao giờ gọi ô A1 là "hàng A1/ dòng A1".
Thứ nhất, sai bản chất của đối tượng - ở đây là 1 ô mà thôi.
Thứ hai, nếu cố suy luận tính từ ô A1 thì không rõ hàng A1 là hàng đứng hay hang ngang.

Túm lại, gọi A1 là một ô.
Gọi hàng 1/ dòng 1, hàng 2, hàng 3...
Gọi cột A, cột B, cột D...

ngoctuyen1995 · 30/11/18

befaint đã viết:
A1 là một ô (cell) duy nhất, nên luôn luôn và luôn luôn gọi nó là ô.
Ví dụ: Ô A1, ô B2, ô G5

Không bao giờ và không bao giờ gọi ô A1 là "hàng A1/ dòng A1".
Thứ nhất, sai bản chất của đối tượng - ở đây là 1 ô mà thôi.
Thứ hai, nếu cố suy luận tính từ ô A1 thì không rõ hàng A1 là hàng đứng hay hang ngang.

Túm lại, gọi A1 là một ô.
Gọi hàng 1/ dòng 1, hàng 2, hàng 3...
Gọi cột A, cột B, cột D...

Em đã sửa lại Tiêu đề rồi ạ..

tam888 · 30/11/18

Thử cách đơn giản này

Mã:

Sub Find_First()
    Dim FindString As String
    Dim Rng As Range
    FindString = "Team in charge"
    If Trim(FindString) <> "" Then
        With Sheets("Data").Cells
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(Rows.Count, .Columns.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
End Sub

ngoctuyen1995 · 30/11/18

tam888 đã viết:

Thử cách đơn giản này

Mã:

Sub Find_First()
    Dim FindString As String
    Dim Rng As Range
    FindString = "Team in charge"
    If Trim(FindString) <> "" Then
        With Sheets("Data").Cells
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(Rows.Count, .Columns.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
End Sub

Em cảm ơn Anh đã quan tâm ạ.. code Tìm đường cột Team in change ạ.. Nếu ứng dụng vào code của em thì sửa như thế nào ạ.. Mong Anh giúp đỡ

thuyyeu99 · 30/11/18

ngoctuyen1995 đã viết:
Em cảm ơn Anh đã quan tâm ạ.. code Tìm đường cột Team in change ạ.. Nếu ứng dụng vào code của em thì sửa như thế nào ạ.. Mong Anh giúp đỡ

Mã:

Dim RngChangeColumn As Long

Sub Tachsheet()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim Item As Variant
    Dim ShNew As Worksheet
    Dim lColumn As Long
    
    Application.ScreenUpdating = False

    Find_First


    Set Sh = Worksheets("Data")
    Set Rng = Sh.Range("S2:S" & Cells(Rows.Count, 2).End(xlUp).Row)
    lColumn = Sheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
    
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Set Rng = Sh.Range("A1:" & GetColumnLetter(RngChange) & Cells(Rows.Count, 2).End(xlUp).Row)
    For Each Item In List
        Set ShNew = Worksheets.Add(After:=Sheets(Sheets.Count))
        ShNew.Name = Item
        Rng.AutoFilter Field:=19, Criteria1:=Item
        Rng.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
        Rng.AutoFilter
        ''Columns("A:AG").EntireColumn.AutoFit
    Next Item
    Sh.Activate
    Application.ScreenUpdating = True
End Sub
Function GetColumnLetter(colNum As Long) As String
    Dim vArr
    vArr = Split(Cells(1, colNum).Address(True, False), "$")
    GetColumnLetter = vArr(0)
End Function
Sub Find_First()
    Dim FindString As String
    Dim Rng As Range
    FindString = "Team in charge"
    If Trim(FindString) <> "" Then
        With Sheets("Data").Cells
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(Rows.Count, .Columns.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                RngChangeColumn = Rng.Column
               Exit Sub
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
End Sub

ngoctuyen1995 · 30/11/18

thuyyeu99 đã viết:

Mã:

Dim RngChangeColumn As Long

Sub Tachsheet()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim Item As Variant
    Dim ShNew As Worksheet
    Dim lColumn As Long
   
    Application.ScreenUpdating = False

    Find_First


    Set Sh = Worksheets("Data")
    Set Rng = Sh.Range("S2:S" & Cells(Rows.Count, 2).End(xlUp).Row)
    lColumn = Sheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
   
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Set Rng = Sh.Range("A1:" & GetColumnLetter(RngChange) & Cells(Rows.Count, 2).End(xlUp).Row)
    For Each Item In List
        Set ShNew = Worksheets.Add(After:=Sheets(Sheets.Count))
        ShNew.Name = Item
        Rng.AutoFilter Field:=19, Criteria1:=Item
        Rng.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
        Rng.AutoFilter
        ''Columns("A:AG").EntireColumn.AutoFit
    Next Item
    Sh.Activate
    Application.ScreenUpdating = True
End Sub
Function GetColumnLetter(colNum As Long) As String
    Dim vArr
    vArr = Split(Cells(1, colNum).Address(True, False), "$")
    GetColumnLetter = vArr(0)
End Function
Sub Find_First()
    Dim FindString As String
    Dim Rng As Range
    FindString = "Team in charge"
    If Trim(FindString) <> "" Then
        With Sheets("Data").Cells
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(Rows.Count, .Columns.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                RngChangeColumn = Rng.Column
               Exit Sub
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
End Sub

Em cảm ơn Anh đã quan tâm ạ.. code hiện đang bị lỗi nếu cột Team In change bị thay đổi vị trí ạ. Anh có thể xem giúp em được không ạ

thuyyeu99 · 30/11/18

ngoctuyen1995 đã viết:
Em cảm ơn Anh đã quan tâm ạ.. code hiện đang bị lỗi nếu cột Team In change bị thay đổi vị trí ạ. Anh có thể xem giúp em được không ạ

Sub Tachsheet()
Dim Sh As Worksheet
Dim Rng As Range
Dim c As Range
Dim List As New Collection
Dim Item As Variant
Dim ShNew As Worksheet
Dim lColumn As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
On Error Resume Next
For Each ws In ActiveWorkbook.Sheets
If Not ws.Name = "Data" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
Find_First
Set Sh = Worksheets("Data")
Set Rng = Sh.Range(GetColumnLetter(RngChange) & "2:" & GetColumnLetter(RngChange) & Cells(Rows.Count, 2).End(xlUp).Row)
lColumn = Sheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column

For Each c In Rng
List.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Rng = Sh.Range("A1:" & GetColumnLetter(lColumn) & Cells(Rows.Count, 2).End(xlUp).Row)
For Each Item In List
Set ShNew = Worksheets.Add(After:=Sheets(Sheets.Count))
ShNew.Name = Item

Rng.AutoFilter Field:=RngChange, Criteria1:=Item
Rng.SpecialCells(xlCellTypeVisible).Copy ShNew.Range("A1")
Rng.AutoFilter
''Columns("A:AG").EntireColumn.AutoFit
Next Item
Sh.Activate
Application.ScreenUpdating = True
End Sub

vanthinh3101 · 1/12/18

ngoctuyen1995 đã viết:
Em cảm ơn Anh đã quan tâm ạ.. code hiện đang bị lỗi nếu cột Team In change bị thay đổi vị trí ạ. Anh có thể xem giúp em được không ạ

Nếu là tôi thì tôi làm như sau:
- Thêm 1 sheets để quy định điều kiện để tách sheet, vị trí điều kiện trong dòng Tiêu đề.
- Viết code có lấy thêm biến về điều kiện tách sheet
- Viết sẵn code để xóa các sheet đã tách khi cần làm mới
Bạn tham khảo file đính kèm, code ở Module2.
Chúc bạn thành công.

[Help] VBA tìm đến tên cột Team in charge

ngoctuyen1995

Thành viên hoạt động

File đính kèm

befaint

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

ngoctuyen1995

Thành viên hoạt động

tam888

Thành viên tích cực

ngoctuyen1995

Thành viên hoạt động

thuyyeu99

Trùm Nhiều Chuyện

ngoctuyen1995

Thành viên hoạt động

thuyyeu99

Trùm Nhiều Chuyện

vanthinh3101

Thành viên tích cực

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

Đếm ngược thời gian