Xin Sửa lệnh VBA

[kiendaide1]

Em có lệnh VBA 100 đồng ra 1 tệp nhưng khi tách tệp ra thì không có tiêu đề. Có bác nào sửa hộ em khi tách từng tập tin thì các tập tin đó đều có tiêu đề ạ. Em cảm ơn
Lện em đính kèm ạ

 

[befaint]

Kien đại để hay Kiên dài? Thích tên nick quá cơ.

Set RangeTieuDe = ThisSheet.Range("Vung tieu de")
For p = 1 To ThisSheet.UsedRange.Rows.Count Step RowsInFile
Set wb = Workbooks.Add
RangeTieuDe.Copy wb.Sheets(1).Range("A1")
'...
RangeToCopy.Copy wb.Sheets(1).Range("A2")

Next p

 

[kiendaide1]

Kien đại để hay Kiên dài? Thích tên nick quá cơ.

Set RangeTieuDe = ThisSheet.Range("Vung tieu de")
For p = 1 To ThisSheet.UsedRange.Rows.Count Step RowsInFile
Set wb = Workbooks.Add
RangeTieuDe.Copy wb.Sheets(1).Range("A1")
'...
RangeToCopy.Copy wb.Sheets(1).Range("A2")

Next p

Phiền anh sửa luôn vào lệnh gửi lại lệnh cho em xin với ạ. em cảm ơn anh.

 

[quick87]

Phiền anh sửa luôn vào lệnh gửi lại lệnh cho em xin với ạ. em cảm ơn anh.

Mình sửa thử theo gợi ý của bài #2, bạn tham khảo nhé :

Sub Test()
  Dim wb As Workbook
  Dim ThisSheet As Worksheet
  Dim NumOfColumns As Integer
  Dim RangeTieuDe As Range
  Dim RangeToCopy As Range
  Dim WorkbookCounter As Integer
  Dim RowsInFile
  Dim Prefix As String

  Application.ScreenUpdating = False

  'Initialize data
  Set ThisSheet = ThisWorkbook.ActiveSheet
  Set RangeTieuDe = ThisSheet.Range("Vung tieu de")
  NumOfColumns = ThisSheet.UsedRange.Columns.Count
  WorkbookCounter = 1
  RowsInFile = 500                   'how many rows (incl. header) in new files?
  Prefix = "test"                    'prefix of the file name

  For p = 1 To ThisSheet.UsedRange.Rows.Count Step RowsInFile
    Set wb = Workbooks.Add
    RangeTieuDe.Copy wb.Sheets(1).Range("A1")

    'Paste the chunk of rows for this file
    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 1, NumOfColumns))
    RangeToCopy.Copy wb.Sheets(1).Range("A2")

    'Save the new workbook, and close it
    wb.SaveAs ThisWorkbook.Path & "\" & Prefix & "_" & WorkbookCounter
    wb.Close

    'Increment file counter
    WorkbookCounter = WorkbookCounter + 1
  Next p

  Application.ScreenUpdating = True
  Set wb = Nothing
End Sub

 

[kiendaide1]

Mình sửa thử theo gợi ý của bài #2, bạn tham khảo nhé :

Sub Test()
  Dim wb As Workbook
  Dim ThisSheet As Worksheet
  Dim NumOfColumns As Integer
  Dim RangeTieuDe As Range
  Dim RangeToCopy As Range
  Dim WorkbookCounter As Integer
  Dim RowsInFile
  Dim Prefix As String

  Application.ScreenUpdating = False

  'Initialize data
  Set ThisSheet = ThisWorkbook.ActiveSheet
  Set RangeTieuDe = ThisSheet.Range("Vung tieu de")
  NumOfColumns = ThisSheet.UsedRange.Columns.Count
  WorkbookCounter = 1
  RowsInFile = 500                   'how many rows (incl. header) in new files?
  Prefix = "test"                    'prefix of the file name

  For p = 1 To ThisSheet.UsedRange.Rows.Count Step RowsInFile
    Set wb = Workbooks.Add
    RangeTieuDe.Copy wb.Sheets(1).Range("A1")

    'Paste the chunk of rows for this file
    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 1, NumOfColumns))
    RangeToCopy.Copy wb.Sheets(1).Range("A2")

    'Save the new workbook, and close it
    wb.SaveAs ThisWorkbook.Path & "\" & Prefix & "_" & WorkbookCounter
    wb.Close

    'Increment file counter
    WorkbookCounter = WorkbookCounter + 1
  Next p

  Application.ScreenUpdating = True
  Set wb = Nothing
End Sub

em cam ơn anh ạ