VBA xóa dòng tiêu đề

sai_hikaru5555 · 6/7/20

Mã:

Sub TachNhom()

Dim myCell As Range
    Dim wks As Worksheet
    Dim DataBaseWks As Worksheet
    Dim ListRange As Range
    Dim dummyRng As Range
    Dim myDatabase As Range
    Dim TempWks As Worksheet
    Dim rsp As Integer
    Dim i As Long
‘chinh dau tieu de
    Const TopLeftCellOfDataBase As String = "A1"
‘chinh cot lay du lieu   
Const KeyColumn As String = "A"

    Set DataBaseWks = Worksheets("DATA")
    i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

    Set TempWks = Worksheets.Add

    With DataBaseWks
        Set dummyRng = .UsedRange
        Set myDatabase = .Range(TopLeftCellOfDataBase, _
                            .Cells.SpecialCells(xlCellTypeLastCell))
    End With

    With DataBaseWks
        Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=TempWks.Range("A1"), _
            Unique:=True

        TempWks.Range("D1").Value = _
            .Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
    End With

    With TempWks
        Set ListRange = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
    End With

    With ListRange
        .Sort Key1:=.Cells(1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom
    End With

    For Each myCell In ListRange.Cells
        If WksExists(myCell.Value) = False Then
            Set wks = Sheets.Add
            On Error Resume Next
            wks.Name = myCell.Value
            If Err.Number <> 0 Then
                MsgBox "Please rename: " & wks.Name
                Err.Clear
                
            End If
            On Error GoTo 0
            wks.Move After:=Sheets(Sheets.Count)
        Else
            Set wks = Worksheets(myCell.Value)
            wks.Cells.Clear
        End If

        If rsp = 6 Then
          DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
        End If
        
        TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value & Chr(34)

        If rsp = 6 Then
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range("D1:D2"), _
              CopyToRange:=wks.Range("A1").Offset(i, 0), _
              Unique:=False
        Else
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range("D1:D2"), _
              CopyToRange:=wks.Range("A1"), _
              Unique:=False
              Columns("D:D").ColumnWidth = 20
              Columns("F:F").ColumnWidth = 20
              Columns("G:G").ColumnWidth = 15
        End If
        
    Next myCell
    
    'Sub tachsheet()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet
For Each sh In Worksheets
    sh.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sh.Name, 51
    ActiveWorkbook.Close
Next
'Application.ScreenUpdating = True
'Application.DisplayAlerts = True
'End Sub
    Application.DisplayAlerts = False
    TempWks.Delete
    Application.DisplayAlerts = True

    MsgBox "TÁCH  PL THANH CONG"

End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Mình có 1 file dữ liệu cần tách ra thành nhiều sheet ( theo cột A) và delete dòng tiêu đề. VBA dưới đây mình đã tách được các sheet thành từng fie rồi, còn phần delete dòng tiêu đề thì mình chưa làm được. Xin các cao nhân chỉ giáo giúp mình nhé. Thanks all!

BuiQuangThuan · 6/7/20

sai_hikaru5555 đã viết:

Mã:

Sub TachNhom()

Dim myCell As Range
    Dim wks As Worksheet
    Dim DataBaseWks As Worksheet
    Dim ListRange As Range
    Dim dummyRng As Range
    Dim myDatabase As Range
    Dim TempWks As Worksheet
    Dim rsp As Integer
    Dim i As Long
‘chinh dau tieu de
    Const TopLeftCellOfDataBase As String = "A1"
‘chinh cot lay du lieu  
Const KeyColumn As String = "A"

    Set DataBaseWks = Worksheets("DATA")
    i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

    Set TempWks = Worksheets.Add

    With DataBaseWks
        Set dummyRng = .UsedRange
        Set myDatabase = .Range(TopLeftCellOfDataBase, _
                            .Cells.SpecialCells(xlCellTypeLastCell))
    End With

    With DataBaseWks
        Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=TempWks.Range("A1"), _
            Unique:=True

        TempWks.Range("D1").Value = _
            .Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
    End With

    With TempWks
        Set ListRange = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
    End With

    With ListRange
        .Sort Key1:=.Cells(1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom
    End With

    For Each myCell In ListRange.Cells
        If WksExists(myCell.Value) = False Then
            Set wks = Sheets.Add
            On Error Resume Next
            wks.Name = myCell.Value
            If Err.Number <> 0 Then
                MsgBox "Please rename: " & wks.Name
                Err.Clear
               
            End If
            On Error GoTo 0
            wks.Move After:=Sheets(Sheets.Count)
        Else
            Set wks = Worksheets(myCell.Value)
            wks.Cells.Clear
        End If

        If rsp = 6 Then
          DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
        End If
       
        TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value & Chr(34)

        If rsp = 6 Then
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range("D1:D2"), _
              CopyToRange:=wks.Range("A1").Offset(i, 0), _
              Unique:=False
        Else
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range("D1:D2"), _
              CopyToRange:=wks.Range("A1"), _
              Unique:=False
              Columns("D:D").ColumnWidth = 20
              Columns("F:F").ColumnWidth = 20
              Columns("G:G").ColumnWidth = 15
        End If
       
    Next myCell
   
    'Sub tachsheet()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet
For Each sh In Worksheets
    sh.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sh.Name, 51
    ActiveWorkbook.Close
Next
'Application.ScreenUpdating = True
'Application.DisplayAlerts = True
'End Sub
    Application.DisplayAlerts = False
    TempWks.Delete
    Application.DisplayAlerts = True

    MsgBox "TÁCH  PL THANH CONG"

End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Mình có 1 file dữ liệu cần tách ra thành nhiều sheet ( theo cột A) và delete dòng tiêu đề. VBA dưới đây mình đã tách được các sheet thành từng fie rồi, còn phần delete dòng tiêu đề thì mình chưa làm được. Xin các cao nhân chỉ giáo giúp mình nhé. Cảm ơn all!

Bạn muốn tách thành sheet hay là tách thành workbook mới thế

huuthang_bd · 6/7/20

Bạn viết được đoạn code đó mà không biết xóa dòng tiêu đề như thế nào à???

sai_hikaru5555 · 7/7/20

huuthang_bd đã viết:
Bạn viết được đoạn code đó mà không biết xóa dòng tiêu đề như thế nào à???

Cái này là chị sếp cũ của mình viết, sử dụng trước giờ, những bây giờ mình cần delete dòng mà không biết làm sao.

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

buiquangthuan đã viết:
Bạn muốn tách thành sheet hay là tách thành workbook mới thế

Cái này là tách thành từng workbook bạn ạ. Mà cái mình cần là khi tách từng workbook thì nó tự động delete dòng tiêu đề trong workbook đó luôn.

BuiQuangThuan · 7/7/20

Vậy là chỉ lấy dữ liệu ở trong thôi à. Chứ ko cần tiêu đề

sai_hikaru5555 · 7/7/20

buiquangthuan đã viết:
Vậy là chỉ lấy dữ liệu ở trong thôi à. Chứ ko cần tiêu đề

Đúng rồi bạn.

Ba Tê · 7/7/20

sai_hikaru5555 đã viết:
Cái này là tách thành từng workbook bạn ạ. Mà cái mình cần là khi tách từng workbook thì nó tự động delete dòng tiêu đề trong workbook đó luôn.

Code khủng mà bỏ ra 1 dòng tiêu đề không xong?

sai_hikaru5555 · 7/7/20

Ba Tê đã viết:
Code trên là tách thành sheet mới trong cùng 1 file mà.

Không đâu bạn, phía cuối code có phần tách thàng từng workbook ah. Bữa giờ mình làm vẫn tách ra thành từng workbook dc mà

BuiQuangThuan · 7/7/20

Ba Tê đã viết:
Code trên là tách thành sheet mới trong cùng 1 file mà.

Cháu thấy nó có tách thành workbook mới. Code trên hình như là nó tách thành các sheet mới. Sau đó mới tách thành workbook mới chú ạ. Nhưng tách luôn cả sheet data

Ba Tê · 7/7/20

buiquangthuan đã viết:
Cháu thấy nó có tách thành workbook mới. Code trên hình như là nó tách thành các sheet mới. Sau đó mới tách thành workbook mới chú ạ. Nhưng tách luôn cả sheet data

Vậy thì viết lại code khác cho "Gom" đúng yêu cầu.

thuyyeu99 · 7/7/20

Cái này chủ Top muốn theo Code cũ thì để xoá dòng đầu thêm wks.Rows("1").Delete sau khi copy từng range qua

TempWks.Delete xoá Sheet tạm thì dời lên phí trên code tách Sheet

if sh.Name <>"data" then
'do somthing
end if

Đưa 2 cái này lên đầu sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False

BuiQuangThuan · 7/7/20

Ban thử code này. Code tham khảo trên diễn đàn không nhớ đường dẫn nguồn

Mã:

Sub ABC()
    Dim Dic As Object, Vung As Range, wbMoi As Workbook
    Dim Arr, n&, iRow&
    Dim sFolder$, TenFile$, TenSheet$
sFolder = ThisWorkbook.Path & "\"
iRow = ThisWorkbook.Worksheets("data").Range("A" & Rows.Count).End(xlUp).Row
Set Vung = ThisWorkbook.Worksheets("data").Range("A1:G" & iRow)
Arr = Vung.Offset(1).Columns("A:A").Value
Set Dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Vung.Range("IV1").Value = Vung.Range("A1").Value
For n = 1 To UBound(Arr)
    If Len(Arr(n, 1)) Then
        TenSheet = Arr(n, 1):  TenFile = Arr(n, 1)
        If Not Dic.Exists(TenSheet) Then
            Dic.Add TenSheet, Empty
            Set wbMoi = Workbooks.Add(1)
            wbMoi.Sheets(1).Name = TenSheet
            Vung.Range("IV2").Value = "'=" & TenSheet
            Vung.AdvancedFilter 2, Vung.Range("IV1:IV2"), wbMoi.Sheets(1).Range("A1")
            wbMoi.Sheets(1).Rows("1").Delete
            wbMoi.SaveAs sFolder & TenFile, xlOpenXMLWorkbook
            wbMoi.Close True
        End If
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Vung.Range("IV1:IV2").ClearContents
If Dic.Count Then MsgBox "Ða tach File xong", , "THÔNG BÁO"
End Sub

Còn dùng code cũ thì như anh thuyyeu99 gợi ý cũng được

VetMini · 7/7/20

sai_hikaru5555 đã viết:
Cái này là chị sếp cũ của mình viết, sử dụng trước giờ, những bây giờ mình cần delete dòng mà không biết làm sao.
...

Lâu ngày mới thấy code viết đẹp vậy.
Lối viết rất chững chạc rành mạch. Đặt tên biến cũng chuẩn.
Chỉ tiếc là lúc gom cái Sub tachSheet() vào thì làm cẩu thả. Đọc như đang ăn bữa ăn ngon là bị món tráng miệng nó cháy khét.
(chỉ nói về cái nhìn thôi, chứ chưa tính đến hiệu dụng)

sai_hikaru5555 · 7/7/20

buiquangthuan đã viết:

Ban thử code này. Code tham khảo trên diễn đàn không nhớ đường dẫn nguồn

Mã:

Sub ABC()
    Dim Dic As Object, Vung As Range, wbMoi As Workbook
    Dim Arr, n&, iRow&
    Dim sFolder$, TenFile$, TenSheet$
sFolder = ThisWorkbook.Path & "\"
iRow = ThisWorkbook.Worksheets("data").Range("A" & Rows.Count).End(xlUp).Row
Set Vung = ThisWorkbook.Worksheets("data").Range("A1:G" & iRow)
Arr = Vung.Offset(1).Columns("A:A").Value
Set Dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Vung.Range("IV1").Value = Vung.Range("A1").Value
For n = 1 To UBound(Arr)
    If Len(Arr(n, 1)) Then
        TenSheet = Arr(n, 1):  TenFile = Arr(n, 1)
        If Not Dic.Exists(TenSheet) Then
            Dic.Add TenSheet, Empty
            Set wbMoi = Workbooks.Add(1)
            wbMoi.Sheets(1).Name = TenSheet
            Vung.Range("IV2").Value = "'=" & TenSheet
            Vung.AdvancedFilter 2, Vung.Range("IV1:IV2"), wbMoi.Sheets(1).Range("A1")
            wbMoi.Sheets(1).Rows("1").Delete
            wbMoi.SaveAs sFolder & TenFile, xlOpenXMLWorkbook
            wbMoi.Close True
        End If
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Vung.Range("IV1:IV2").ClearContents
If Dic.Count Then MsgBox "Ða tach File xong", , "THÔNG BÁO"
End Sub

Còn dùng code cũ thì như anh thuyyeu99 gợi ý cũng được

Mình làm được rồi nhé. Cám ơn bạn.

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

thuyyeu99 đã viết:
Cái này chủ Top muốn theo Code cũ thì để xoá dòng đầu thêm wks.Rows("1").Delete sau khi copy từng range qua

TempWks.Delete xoá Sheet tạm thì dời lên phí trên code tách Sheet

if sh.Name <>"data" then
'do somthing
end if

Đưa 2 cái này lên đầu sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Mình làm được rồi nhé. Cám ơn bạn!

VBA xóa dòng tiêu đề

sai_hikaru5555

Thành viên mới

File đính kèm

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

huuthang_bd

Chuyên gia GPE

sai_hikaru5555

Thành viên mới

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

sai_hikaru5555

Thành viên mới

Ba Tê

Cạo Rồi Khỏi Gội

sai_hikaru5555

Thành viên mới

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

Ba Tê

Cạo Rồi Khỏi Gội

thuyyeu99

Trùm Nhiều Chuyện

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

File đính kèm

VetMini

Ăn cùng góc phố

sai_hikaru5555

Thành viên mới

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