Hello everyone...
I want to split a data set into different workbooks based on unique value in column N.
Save the new workbook based on its unique value (name).
I couldn't find any VBA command that works for me, but instead
I found VBA command in the internet to split it into different sheets which works perfectly for me.
My data has 3 header rows and the column that has unique value in column N.
But then I couldn't work out how to save each sheet with its name and delete the rest of the sheets.
Go back to the original file and repeat the same process.
Any help is appreciated.
Below is the current VBA that I'm using.
I want to split a data set into different workbooks based on unique value in column N.
Save the new workbook based on its unique value (name).
I couldn't find any VBA command that works for me, but instead
I found VBA command in the internet to split it into different sheets which works perfectly for me.
My data has 3 header rows and the column that has unique value in column N.
But then I couldn't work out how to save each sheet with its name and delete the rest of the sheets.
Go back to the original file and repeat the same process.
Any help is appreciated.
Below is the current VBA that I'm using.
VBA Code:
Sub Createfilebasedonwarehouse()
Dim MyPath As String
Dim MyFile As String
Dim LatestFile As String
Dim LatestDate As Date
Dim LMD As Date
Dim currentDateTime As String
Dim csvFilePath As String
Dim excelFilePath As String
Dim ws As Worksheet
Dim dateColumns As Variant
Dim i As Integer
Dim currentYear As String
Dim currentMonth As String
Dim currentDate As String
Dim lr As Long
Dim vcol, j As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
Dim xWS As Worksheet
Dim wsToKeep As String
' Get the current date and time
currentDateTime = Format(Now, "yyyy-mm-dd_hh-mm-ss")
' Get the current year in "yyyy 年" format
currentYear = Format(Date, "yyyy年")
' Get the current month in "m" format
currentMonth = Format(Date, "m月")
' Get today's date in "d" format
currentDate = Format(Date, "d日")
' Define the file paths
filePath = "\\Share\data\warehouse\"
Filename = "warehousedata_" & currentDateTime & ".xlsx"
MyPath = "C:\Users\PC-1001-3\Downloads\"
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
MyFile = Dir(MyPath & "*.csv", vbNormal)
If Len(MyFile) = 0 Then
MsgBox "No files were found...", vbExclamation
Exit Sub
End If
Do While Len(MyFile) > 0
LMD = FileDateTime(MyPath & MyFile)
If LMD > LatestDate Then
LatestFile = MyFile
LatestDate = LMD
End If
MyFile = Dir
Loop
' Open the CSV file
Workbooks.OpenText Filename:=MyPath & LatestFile, DataType:=xlDelimited, Comma:=True
' Set the worksheet
Set ws = ActiveSheet
' Define the columns to be converted to date format (e.g., columns 2 and 4)
dateColumns = Array(2, 3)
'
' Loop through each column and convert to date format
For i = LBound(dateColumns) To UBound(dateColumns)
ws.Columns(dateColumns(i)).NumberFormat = "yyyy/mm/dd"
Next i
' Define the columns to be changed to text format (e.g., columns 1 and 3)
colToText = Array(1, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40)
' Loop through the specified columns and change their format to text
For j = LBound(colToText) To UBound(colToText)
ws.Columns(colToText(j)).NumberFormat = "@"
Next j
Columns("A:AN").Select
Columns("A:AN").EntireColumn.AutoFit
' Save the workbook as an Excel file
ActiveWorkbook.SaveAs Filename:=filePath & Filename, FileFormat:=xlOpenXMLWorkbook
'Rename the current sheet and change the format of 3 column to date and number
ActiveSheet.Name = "CSVBASE"
Columns("B:C").Select
Selection.Copy
Sheets.Add after:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Name = "Sheet1"
Range("C4").Select
Application.CutCopyMode = False
Columns("C:D").ColumnWidth = 10.63
Range("C4").Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-2],""yyyy/mm/dd"")"
Range("D4").Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-2],""yyyy/mm/dd"")"
Range("C4:D4").Select
Selection.AutoFill Destination:=Range("C4:D" & Range("A" & Rows.Count).End(xlUp).Row)
Range("C4:D4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("CSVBASE").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("O:O").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Columns("E:E").Select
ActiveSheet.Paste
Range("F4").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=TEXT(RC[-1],""0000000000000"")"
Range("F5").Select
Columns("F:F").EntireColumn.AutoFit
Range("F4").Select
Selection.AutoFill Destination:=Range("F4:F" & Range("A" & Rows.Count).End(xlUp).Row)
Range("F4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("CSVBASE").Select
Range("O4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Sheet1").Delete
Range("A1").Select
'Split workbook based on warehouse code
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For j = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(j, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(j, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(j, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For j = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(j) & ""
If Not Evaluate("=ISREF('" & myarr(j) & "'!A1)") Then
Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))
xWS.Name = myarr(j) & ""
Else
xWS.Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
xWS.Paste Destination:=xWS.Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(j) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub
