[Funland] Chỉ giáo sửa lệnh VBA

[Thỏ và Gấu]

Em có cái lệnh VBA tách 100 dòng ra 1 file nhưng khi tách nó ko dư lại tiêu đề của nội dung. Em muốn nhờ các bác sửa hộ em lệnh cho nó dữ lại tiêu đề ở các file tác ra ạ. code VBA em đính kèm ạ. Em cảm ơn các bác nhiều
Sub Test()
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
Dim RangeToCopy As Range
Dim WorkbookCounter As Integer
Dim RowsInFile
Dim Prefix As String
Application.ScreenUpdating = False
'Initialize data
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count
WorkbookCounter = 1
RowsInFile = 100 '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
'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("A1")
'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

 

[Of.NguyenLinh]

Cụ đặt code vào phần này dễ view hơn này.
Em ủn thôi, VBA em chịu
Về excel và VBA, em nghĩ cụ hỏi bên cộng đồng excel hay hơn

 

[PhungtheNghiep]

Nập trình cụ vào đây là lệch pha rồi

 

[Bin09]

Em có cái lệnh VBA tách 100 dòng ra 1 file nhưng khi tách nó ko dư lại tiêu đề của nội dung. Em muốn nhờ các bác sửa hộ em lệnh cho nó dữ lại tiêu đề ở các file tác ra ạ. code VBA em đính kèm ạ. Em cảm ơn các bác nhiều
Sub Test()
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
Dim RangeToCopy As Range
Dim WorkbookCounter As Integer
Dim RowsInFile
Dim Prefix As String
Application.ScreenUpdating = False
'Initialize data
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count
WorkbookCounter = 1
RowsInFile = 100 '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
'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("A1")
'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 đã chỉnh giúp cụ:
- Điều chỉnh bước nhảy giảm đi 1 (vì trừ đi header)
- Bổ sung ghi header cho từng file trước khi ghi nội dung

Bản full không che đây cụ nhé
---------------------------------------------------------------------
Sub Test()
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
Dim RangeToCopy As Range
Dim HeaderRange As Range
Dim WorkbookCounter As Integer
Dim RowsInFile
Dim Prefix As String
Application.ScreenUpdating = False
'Initialize data
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count
Set HeaderRange = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))

WorkbookCounter = 1
RowsInFile = 100 'how many rows (incl. header) in new files?
Prefix = "test" 'prefix of the file name
For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1
Set wb = Workbooks.Add
'Paste the chunk of rows for this file
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))
HeaderRange.Copy wb.Sheets(1).Range("A1")
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