Sub Tach_file()
bạn ơi bạn có thể sửa lại cho nó lấy hết tiêu đề không bạn , code chỉ lấy 3 dòng mà tiêu đề tới 4 dòng , mình cảm ơn bạn
Sub Tach_file()
Dim lastRow As Long, i As Long, r As Long, c As Long, data(), item(), result(), Xom As Variant
Dim shp As Shape, dic As Object, sh As Worksheet
Set sh = ActiveSheet
Set dic = CreateObject("Scripting.Dictionary")
dic.comparemode = vbTextCompare
lastRow = sh.Cells(Rows.Count, "N").End(xlUp).Row
If lastRow < 5 Then Exit Sub
data = sh.Range("A5:AY" & lastRow).Value 'Lay toi dong cuoi cung chua xom
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For i = 1 To UBound(data)
Xom = Trim(data(i, 14))
If Len(Xom) Then
If Not dic.exists(Xom) Then
ReDim item(1 To 1)
item(1) = i
dic.Add Xom, item
Else
item = dic.item(Xom)
ReDim Preserve item(1 To UBound(item) + 1)
item(UBound(item)) = i
dic.item(Xom) = item
End If
End If
Next
If dic.Count Then
For Each Xom In dic.keys
item = dic.item(Xom)
ReDim result(1 To UBound(item), 1 To UBound(data, 2))
For r = 1 To UBound(item)
For c = 1 To UBound(data, 2)
result(r, c) = data(item(r), c)
Next c
Next r
sh.Copy
With ActiveSheet
.Range("A5:AY1000").Clear
For Each shp In .Shapes
shp.Delete
Next shp
With .Range("A5").Resize(UBound(result), UBound(result, 2))
.Value = result
.Borders.LineStyle = xlContinuous
End With
.Parent.SaveAs ThisWorkbook.Path & "\" & Xom, xlOpenXMLWorkbook
.Parent.Close
End With
Next Xom
End If
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End SubHủy merge các ô ở dòng 1 đi, định dạng ngang qua các ô theo kiểu Center Across Selection, và sửa lại các chỗ màu đỏ như code bên dưới:
Sub Tach_file()
Dim Dic As Object
Dim i As Long, Data(), Sdata As Range, Xom As Variant
Set Dic = CreateObject("scripting.dictionary")
Data = Range([A5], [N55536].End(xlUp)).Value 'Lay toi dong cuoi cung chua xom'
Set Sdata = Range("A4:AY" & [N55536].End(xlUp).Row +3) ' lay toi dong cuoi cung cua xom mo rong ra het du lieu'
With Application
.ScreenUpdating = False
.DisplayAlerts = False
For i = 1 To UBound(Data)
If Data(i, 14) <> "" Then
Dic.Item(Data(i, 14)) = ""
End If
Next
For Each Xom In Dic.keys
With Sdata
.AutoFilter 14, Xom
.Offset(-3).Copy
Workbooks.Add
With ActiveWorkbook
With .ActiveSheet
.Name = Xom
.[A1].PasteSpecial 1
.[A:AY].Columns.AutoFit
End With
.SaveAs ThisWorkbook.Path & "\" & Xom, 18
.Close
End With
.AutoFilter
End With
Next
.ScreenUpdating = True
.DisplayAlerts = True
End With
End SubCode của bạn mình thử thì nó không tách theo xóm được, nó tách ra xóm 1 ra tất cả các xóm luôn, xóm 2 xuất ra từ xóm 2 đến xóm n, ...., không phải ra từng xóm.
Code của bạn mình thử thì nó không tách theo xóm được, nó tách ra xóm 1 ra tất cả các xóm luôn, xóm 2 xuất ra từ xóm 2 đến xóm n, ...., không phải ra từng xóm
Không Hủy merge các ô ở dòng 1 có làm được không bạn.
Góp ý cho bạn:
File đầu tiên bạn chỉ chép đến dòng 2, không vấn đề gì. Chỉ đến khi bạn yêu cầu chép luôn dòng 1 thì mới sinh ra vấn đề. Lúc đầu đó, tôi chỉ sửa tí ti ở vài chỉ số chứ không muốn can thiệp gì vào code của bạn. Sau cũng thế, tôi thấy chỉ hủy merge mới được, không can thiệp sâu hơn nữa.
