membagi baris excel dari 1 file menjadi banyak file
kode ini utk split file excel yang terlalu banyak barisnya dan dipecah2 menjadi beberapa file , metode ini saya pakai utk import data DPT KPU ke aplikasi apdalih pro, dimana filenya sangat besar sampai 65.000 baris. karena terlalu besar dan aplikasi gagal import nya maka saya bagi menjadi 1 file utk setiap 3000 baris
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 = 11
RowsInFile = 3000 'how many rows (incl. header) in new files?
Prefix = "KEDUNGADEM" '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
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 = 11
RowsInFile = 3000 'how many rows (incl. header) in new files?
Prefix = "KEDUNGADEM" '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
Komentar
Posting Komentar