My goal is to sort an entire raw data workbook based on smallest to largest in column C. This ensures that, in this case, the pole #'s are sorted in order on the output excel file. I am using VBA for this and cannot seem to figure it out. Below is my existing code.
Sub ECOECCSV()
Dim desPathName As Variant
desPathName = Application.GetOpenFilename(FileFilter:="Excel Files (*.csv*), *.csv*", Title:="Please select a file")
If desPathName = False Then
MsgBox "Stopping because you did not select a file. Reselect a destination file through the menu"
Exit Sub
Else
Workbooks.Open Filename:=desPathName
Set des = Workbooks.Open(desPathName, True, False)
End If
ActiveSheet.Name = "RawData"
Set RDBook = Worksheets("RawData").Parent
Workbooks.Add
If Worksheets.Count > 2 Then
Application.DisplayAlerts = False ' prevent are you sure message while deleting
Sheets("Sheet3").Delete
Sheets("Sheet2").Delete
Application.DisplayAlerts = True
End If
lastcolumn = 1
Do While HomeSheet.Cells(1, lastcolumn) <> ""
lastcolumn = lastcolumn + 1
Loop
lastrow = 2
Do While HomeSheet.Cells(lastrow, 1).Value <> ""
HomeSheet.Cells(lastrow, PoleNum) = CDbl(HomeSheet.Cells(lastrow, PoleNum))
lastrow = lastrow + 1
Loop
sortColumn = Cells(1, PoleNum).Address(RowAbsolute:=False,
ColumnAbsolute:=False)
sortEnd = Cells(lastrow, lastcolumn).Address(RowAbsolute:=False,
ColumnAbsolute:=False)
HomeSheet.Range("A1:" & sortEnd).Sort key1:=HomeSheet.Range(sortColumn),
order1:=xlAscending, Header:=xlYes
Sheets(1).Name = "Make-Ready"
Set MRBook = Worksheets("Make-Ready").Parent
"Raw Data" Worksheets is the input file that will be used in the macro, that is the document I want the pole #'s sorted. "Make Ready" is the document that will be output. from lastcolumn = 1 to Header:=xlYes is my code that is not working.
Reminder: my goal is to sort the entire sheet based off that one column.
Related
My VBA knowledge is very limited, so looking for some help here. Tried some Googling and putting together a code but hasn't met the goal. Appreciate the help here!
I have 2 worksheets:
Data - source worksheet with the data to be copied
Dashboard - Target sheet for pasting
Data sheet - It has multiple columns, the ones I have named are the ones I need to be copied except the column named "Sold?" which is for criteria. The other columns with no names in the image actually have data, to avoid confusion I have removed them here.
This sheet grows and I will add a new row of data when needed.
Dashboard Sheet - When I click "Refresh" button, I want the code to check the "Data" sheet and if a row meets of criteria of Sold? = "N", then only data from column C,G,J,M should be copied and pasted into columns B,C,D,E of "Dashboard" sheet. Additional criteria: if an investment name repeats, the details need to be summed up and shown in Dashboard sheet. I have provided my expected output in the image. (ABC & TY summed up)
I have tried a bit but unable to incorporate all the criteria and this code when run doesn't throw an error but does nothing, no output.
Private Sub Refresh_Click()
Worksheets("Dashboard").Activate
Application.ScreenUpdating = True
a = Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
For i = 12 To a
If Worksheets("Data").Cells(i, 15).Value = "N" Then
Worksheets("Data").Cells(i, 3).Copy
Worksheets("Data").Cells(i, 7).Copy
Worksheets("Data").Cells(i, 13).Copy
Worksheets("Data").Cells(i, 14).Copy
Worksheets("Dashboard").Activate
Worksheets("Dashboard").Range("B6:G25").Select
ActiveSheet.Paste
End If
Next
Application.CutCopyMode = False
End Sub
I strongly suggest a pivot table. Still if you want VBA based solution, you might try this code:
Option Explicit
Private Sub Refresh_Click()
'Declarations.
Dim BlnHiddenColumns() As Boolean
Dim DblFirstRow As Double
Dim DblLastRow As Double
Dim DblCounter01 As Double
Dim DblCounterLimit01 As Double
Dim DblInvestmentNameColumn As Double
Dim DblQuantityColumn As Double
Dim DblAfterChargeColumn As Double
Dim DblCurrentPLColumn As Double
Dim DblSoldColumn As Double
Dim RngData As Range
Dim RngResult As Range
Dim StrAutofilterAddress As String
Dim StrMarker As String
Dim StrInvestmentNameHeader As String
Dim StrQuantityHeader As String
Dim StrAfterChargeHeader As String
Dim StrCurrentPLHeader As String
Dim WksData As Worksheet
Dim WksDashboard As Worksheet
Dim WksPivotTable As Worksheet
Dim PvtPivotTable01 As PivotTable
'Settings.
DblInvestmentNameColumn = 3
DblQuantityColumn = 7
DblAfterChargeColumn = 10
DblCurrentPLColumn = 13
DblSoldColumn = 15
DblFirstRow = 12
DblCounterLimit01 = 1000
StrMarker = "N"
Set WksData = Worksheets("Data")
DblLastRow = WksData.Cells(Rows.Count, "B").End(xlUp).Row
Set RngData = WksData.Range(WksData.Cells(DblFirstRow - 1, Excel.WorksheetFunction.Min(DblInvestmentNameColumn, DblQuantityColumn, DblAfterChargeColumn, DblCurrentPLColumn, DblSoldColumn)), WksData.Cells(DblLastRow, Excel.WorksheetFunction.Max(DblInvestmentNameColumn, DblQuantityColumn, DblAfterChargeColumn, DblCurrentPLColumn, DblSoldColumn)))
ReDim BlnHiddenColumns(1 To RngData.Columns.Count)
Set WksDashboard = Worksheets("Dashboard")
Set RngResult = WksDashboard.Range("B6")
StrInvestmentNameHeader = WksDashboard.Range("B5").Value
StrQuantityHeader = WksDashboard.Range("C5").Value
StrAfterChargeHeader = WksDashboard.Range("D5").Value
StrCurrentPLHeader = WksDashboard.Range("E5").Value
'Turning off screen updating.
Application.ScreenUpdating = False
'Checking for any previous results list.
If Excel.WorksheetFunction.CountBlank(RngResult) <> RngResult.Cells.Count Then
DblCounter01 = 0
'Checking each row of the result list until an entirely blank row is found.
Do Until Excel.WorksheetFunction.CountBlank(RngResult.Offset(DblCounter01, 0)) = RngResult.Cells.Count
DblCounter01 = DblCounter01 + 1
'If the number of rows checked is equal or superior to DblCounterLimit01 the macro is terminated.
If DblCounter01 >= DblCounterLimit01 Then
MsgBox "Please clear the current holdings list manually", vbCritical + vbOKOnly, "Unable to clear the current list"
Exit Sub
End If
Loop
'Clearing the list.
RngResult.Parent.Range(RngResult, RngResult.Offset(DblCounter01 - 1)).ClearContents
End If
'Checking for existing autofilter in WksData.
If WksData.AutoFilterMode = True Then
'Coping the address of the autofilter in WksData.
StrAutofilterAddress = WksData.AutoFilter.Range.Address
End If
'Removing any autofilter in WksData.
WksData.AutoFilterMode = False
'Covering each column of RngData.
For DblCounter01 = 1 To RngData.Columns.Count
'Setting BlnHiddenColumns accordingly to the RngData columns' status (hidden/not hidden).
BlnHiddenColumns(DblCounter01) = RngData.Columns(DblCounter01).Hidden
'Hiding the columns of RngData we won't copy.
Select Case DblCounter01 + RngData.Column - 1
Case Is = DblInvestmentNameColumn, DblQuantityColumn, DblAfterChargeColumn, DblCurrentPLColumn
RngData.Columns(DblCounter01).Hidden = False
Case Else
RngData.Columns(DblCounter01).Hidden = True
End Select
Next
'Filtering RngData.
RngData.AutoFilter Field:=DblSoldColumn - RngData.Column + 1, Criteria1:=StrMarker
'Copying the filtered RngData into RngResult.
RngData.Resize(RngData.Rows.Count - 1, RngData.Columns.Count).Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy RngResult
'Restoring the RngData columns to their previous status (hidden/not hidden).
For DblCounter01 = 1 To RngData.Columns.Count
If BlnHiddenColumns(DblCounter01) Then
RngData.Columns(DblCounter01).Hidden = True
Else
RngData.Columns(DblCounter01).Hidden = False
End If
Next
'Removing any autofilter in WksData.
WksData.AutoFilterMode = False
'Restoring any pre-existing autofilter in WksData.
If StrAutofilterAddress <> "" Then
WksData.Range(StrAutofilterAddress).AutoFilter
End If
'Setting RngResult to cover the imported list (headers included).
Set RngResult = RngResult.Offset(-1, 0)
Set RngResult = WksDashboard.Range(RngResult, RngResult.End(xlDown).End(xlToRight))
'Creating WksPivotTable.
Set WksPivotTable = Sheets.Add
'Creating PvtPivotTable01.
Set PvtPivotTable01 = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=RngResult, _
Version:=7 _
).CreatePivotTable(TableDestination:=WksPivotTable.Cells(1, 1), _
TableName:="Temporary Pivot Table", _
DefaultVersion:=7 _
)
'Setting PvtPivotTable01.
With PvtPivotTable01.PivotFields(StrInvestmentNameHeader)
.Orientation = xlRowField
.Position = 1
End With
With PvtPivotTable01
.AddDataField .PivotFields(StrQuantityHeader), "Sum of " & StrQuantityHeader, xlSum
.AddDataField .PivotFields(StrAfterChargeHeader), "Sum of " & StrAfterChargeHeader, xlSum
.AddDataField .PivotFields(StrCurrentPLHeader), "Sum of " & StrCurrentPLHeader, xlSum
.ColumnGrand = False
End With
'Clearing the data from RngResult.
RngResult.Offset(1, 0).Resize(RngResult.Rows.Count - 1).ClearContents
'Copying the PvtPivotTable01 content to RngResult.
PvtPivotTable01.DataBodyRange.Offset(0, -1).Resize(, PvtPivotTable01.DataFields.Count + 1).Copy RngResult.Cells(2, 1)
'Deleting WksPivotTable.
Application.DisplayAlerts = False
WksPivotTable.Delete
Application.DisplayAlerts = True
'Restoring screen updating.
Application.ScreenUpdating = False
End Sub
I've intentionally made it longer than the necessary, especially by creating many variables to avoid hard coded data. This method might be useful in more complex and/or longer codes.
I want to start a loop mid column (Row 15 let's say).
Current code (part of a much larger script)
Range("C2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C3"
Dim BlankFound As Boolean
Dim x As Long
'Loop until a blank cell is found in Column C
Do While BlankFound = False
x = x + 1
If Cells(x, "C").Value = "" Then
BlankFound = True
End If
Loop
I tried changing the column ref (C) to a cell (C15). I tried to specify the start and end point (C15:C).
We have a client order form that when they click a button converts to another format ready to be uploaded. The client will fill out various fields that populate rows 1 and 2 (name, address, etc.), then from row three it is the number of orders, i.e.
row
3 part number quantity availability
4 part number quantity availability
I want it to look at the original form and only populate down if it finds a value in the original form's cell.
Then at the end I have another row to add, so I need to be able to say when this loop finishes, add these values (these are just an extra row of totals and some formatting).
The full code-
Sub ButtonMacroLatest()
'Hide alerts
Application.DisplayAlerts = False
'
' Macro8 Macro
'
'Save to users device
ChDir "U:\WINDOWS"
ActiveWorkbook.SaveAs Filename:="U:\WINDOWS\OrderForm.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
'Create new workbook and populate
Workbooks.Add
ActiveCell.FormulaR1C1 = "MSG"
Range("B1").FormulaR1C1 = "=[OrderForm.xlsx]Order!R[1]C"
Range("C1").FormulaR1C1 = "=[OrderForm.xlsx]Order!R[1]C[3]"
Range("D1").FormulaR1C1 = "1400008000"
Range("E1").FormulaR1C1 = "501346009175"
Range("F1").FormulaR1C1 = "=TODAY()"
Range("G1").FormulaR1C1 = "=Now()"
Selection.NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
Range("A2").FormulaR1C1 = "HDR"
Range("B2").FormulaR1C1 = "C"
Range("C2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R4C2"
Range("G2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R[1]C[3]"
Range("H2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R2C4"
Range("K2").FormulaR1C1 = "STD"
Range("L2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R5C2"
Range("N2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R7C2"
Range("O2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R8C2"
Range("Q2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R9C2"
Range("R2").FormulaR1C1 = "=[OrderForm.xlsx]Order!R12C2"
Range("A3").FormulaR1C1 = "POS"
Range("B3").FormulaR1C1 = "=Row()*10-20"
Range("C3").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C3"
Dim BlankFound As Boolean
Dim x As Long
'Loop until a blank cell is found in Column C
Do While BlankFound = False
x = 14
x = x + 1
If Cells(x, "C").Value = "" Then
BlankFound = True
End If
Loop
Range("D3").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C1"
Range("E3").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C2"
Range("F3").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C5"
Range("G3").FormulaR1C1 = "=[OrderForm.xlsx]Order!R15C7"
'Preformat cells to remove 0 value
Range("A1:AP1000").Select
Range("AP1000").Activate
Selection.NumberFormat = "#;#;"
Range("H3").FormulaR1C1 = "GBP"
Range("L3").FormulaR1C1 = "TRA"
Range("M3").FormulaR1C1 = "=COUNTIF(C[-3], ""POS"")+COUNTIF(C[-3], ""HDR"")"
'Reinstate alerts
Application.DisplayAlerts = True
End Sub
In the client facing form A15:C15 are material/part numbers. If populated those rows should fill down in the new form until there is no entry in the original form.
Customer form
I haven't been able to figure out exactly where you're grabbing values from and where you're putting them, but hopefully this bit of code will give you enough ideas to get yours sorted.
Public Sub ButtomMacroLatest()
Dim wrkBk As Workbook
Dim wbOF As Workbook
Dim shtCSV As Worksheet
Dim shtOF As Worksheet
Dim lLastRow As Long
Dim x As Long, y As Long
'OrderForm is closed so needs opening:
'Set wbOF = Workbooks.Open("U:\.......\OrderForm.xlsx")
'OrderForm is the workbook containing this code:
Set wbOF = ThisWorkbook
'Set a reference to the "Order" sheet and
'find the last row - based on column A being populated.
Set shtOF = wbOF.Worksheets("Order")
lLastRow = shtOF.Cells(Rows.Count, 1).End(xlUp).Row
'Create workbook with 1 sheet and set reference to that sheet.
Set wrkBk = Workbooks.Add(xlWBATWorksheet)
Set shtCSV = wrkBk.Worksheets(1)
'Add headings to the sheet.
shtCSV.Range("A1:G1") = Array("MSG", "SomeHeading", "SomeOtherHeading", "1400008000", _
"501346009175", Date, Now)
'Copy values in cell "A15:J<LastRow>" to "A2" on the new sheet.
With shtOF
'Straight copy
'.Range(.Cells(15, 1), .Cells(lLastRow, 10)).Copy _
Destination:=shtCSV.Range("A2")
'Paste Special
.Range(.Cells(15, 1), .Cells(lLastRow, 10)).Copy
With shtCSV.Range("A2")
.PasteSpecial xlPasteValuesAndNumberFormats
.PasteSpecial xlPasteFormats
End With
'Make the value of one cell equal the value of another cell
'in a loop from row 15 to LastRow and column 1 to 10.
'For x = 15 To lLastRow
' For y = 1 To 10
' shtCSV.Cells(x - 13, y) = .Cells(x, y)
' Next y
'Next x
End With
wrkBk.SaveAs Environ("temp") & "/CSV File.csv", FileFormat:=xlCSV, CreateBackup:=False
End Sub
This took something a lot simpler, it works a treat for what I need. Code:
'Fills column to last row of data from Cell C15
Dim LastRow As Long
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Range("C15:C" & LastRow).FillDown
Range("D15:D" & LastRow).FillDown
Range("E15:E" & LastRow).FillDown
Thanks for all of the responses.
I have a workbook that creates other workbooks and shifts data to them based on the value in column one. Afterwords I need the workbook to store the data it has just copied in a sheet of the same name as the stored variable (in the next empty row), or create the tab if it does not exist.
However i'm having an issue pasting into the tab with the name of the variable, and no idea how to create a new sheet if the variable does not already exist as a sheet.
It's the With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste i'm having trouble with.
Current code below. Thanks!
Private Sub CopyItOver()
Dim myVal As String
Dim SupID As String
'Store Supplier ID
SupID = Trim(Sheets("Raw Data").Range("A2").Value)
'Create workbook
Set newbook = Workbooks.Add
'Copy Records
Set myRng = Workbooks("Book1.xlsm").Worksheets("Raw Data").Range("B2:X7")
myRng.Copy
newbook.Worksheets("Sheet1").Range("A2").PasteSpecial (xlPasteValues)
'Create Header
newbook.Worksheets("Sheet1").Range("A1").Value = "ZHF"
newbook.Worksheets("Sheet1").Range("B1").Value = "CTO"
newbook.Worksheets("Sheet1").Range("C1").Value = "RET"
newbook.Worksheets("Sheet1").Range("D1").Value = SupID
newbook.Worksheets("Sheet1").Range("E1").Value = "RET"
newbook.Worksheets("Sheet1").Range("F1").Value = "RET"
newbook.Worksheets("Sheet1").Range("G1").Value = "6"
newbook.Worksheets("Sheet1").Range("H1").Value = "PROD"
newbook.Worksheets("Sheet1").Range("J1").Value = newbook.Worksheets("Sheet1").Range("B1").Value _
& newbook.Worksheets("Sheet1").Range("D1").Value & "TEMPNUMBER"
newbook.Worksheets("Sheet1").Range("I1").Value = newbook.Worksheets("Sheet1").Range("J1").Value _
& newbook.Worksheets("Sheet1").Range("C1").Value & ".CSV"
newbook.Worksheets("Sheet1").Range("K1") = Format(Date, "ddmmyyyy")
newbook.Worksheets("Sheet1").Range("L1").Value = "Unknown"
newbook.Worksheets("Sheet1").Range("M1").Value = "1"
LastRow = newbook.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
'Create Footer
newbook.Worksheets("Sheet1").Range("A" & LastRow + 1).Value = "ZFV"
newbook.Worksheets("Sheet1").Range("B" & LastRow + 1).Value = "BATCH" & "TEMPNUMBER"
newbook.Worksheets("Sheet1").Range("C" & LastRow + 1).Value = WorksheetFunction.CountIf(Sheets("Sheet1").Range("A1:A1000"), "RET")
'Name Sheet
myVal = newbook.Worksheets("Sheet1").Range("J1").Value & "RET"
newbook.Worksheets("Sheet1").Name = myVal
'Copy to relevant matching sheet
With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste
End With
'Save Workbook
NewBook.SaveAs Filename:=NewBook.Worksheets("Sheet1").Range("I1").Value
End Sub
Function DLastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
The error's occurring because Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste is trying to find that worksheet on your active book, ie the new book. You'd need either to Activate your raw data workbook or change the line to ThisWorkbook.Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste.
However, it's not great to use (either explicitly or implicitly) Activate, Select or other keystroke style commands in VBA. Given that you're only copying values (and not the worksheet formats) then, you'd probably be better served reading the data into an array of variants and manipulating those. I've adjusted your code to demonstrate this.
There are some other coding aspects that might not be as robust as they could be. I won't list them all but a comparison of this code with yours will help you see them.
Private Sub CopyItOver()
Dim newBook As Workbook
Dim supSheet As Worksheet
Dim v As Variant
Dim supID As String
Dim namePrefix As String
Dim footerCount As Integer
Dim i As Integer
'Store Supplier ID
supID = Trim(ThisWorkbook.Worksheets("Raw Data").Range("A2").value)
namePrefix = "CTO" & supID & "TEMPNUMBER"
'Create workbook
Set newBook = Workbooks.Add
'Copy Records
v = rawDataSheet.Range("B2:X7").value
For i = 1 To UBound(v, 1)
If v(i, 1) = "RET" Then footerCount = footerCount + 1
Next
'Write new sheet
With newBook.Worksheets(1)
'Values
.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).value = v
'Header
.Range("A1").Resize(, 13) = Array( _
"ZHF", "CTO", "RET", supID, "RET", "RET", "6", "PROD", _
namePrefix & "RET.CSV", namePrefix, _
Format(Date, "ddmmyyyy"), "Unknown", "1")
'Footer
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 3).value = Array( _
"ZFV", "BATCH TEMPNUMBER", footerCount)
'Name
.Name = namePrefix & "RET"
'Save
.SaveAs Filename:=namePrefix & "RET.CSV"
End With
'Copy to relevant matching sheet
On Error Resume Next
Set supSheet = ThisWorkbook.Worksheets(supID)
On Error Goto 0
If newSheet Is Nothing Then
With ThisWorkbook.Worksheets
Set supSheet = .Add(After:=.Item(.Count))
End With
supSheet.Name = supID
End If
With supSheet
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(v, 1), UBound(v, 2)).value = v
End With
End Sub
A few things that aren't quite right:
Add Option Explicit at the top of the module and declare your variables.
LastRow will be a Long data type, but you're trying to use it like an array in With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste. Just use LastRow+1.
With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste
End With should probably be Worksheets(SupID).Range("A" & LastRow + 1).Paste, but it will paste myRng - can't see anything else you've copied.
At the start of the code you reference Workbooks("Book1.xlsm"). If this is the workbook that the code is in I'd change it to ThisWorkbook.
SupID looks at Raw Data on whichever workbook is active at the time (you'd don't specify the workbook when initialising that variable).
This function will return TRUE/FALSE if a named worksheet exists:
Public Function WorkSheetExists(SheetName As String) As Boolean
Dim wrkSht As Worksheet
On Error Resume Next
Set wrkSht = ThisWorkbook.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
Hope that points you in the right direction :)
Edit:
Just noticed to....
Rather than write:
newbook.Worksheets("Sheet1").Range("A1").Value = "ZHF"
newbook.Worksheets("Sheet1").Range("B1").Value = "CTO"
newbook.Worksheets("Sheet1").Range("C1").Value = "RET"
newbook.Worksheets("Sheet1").Range("D1").Value = SupID
newbook.Worksheets("Sheet1").Range("E1").Value = "RET"
newbook.Worksheets("Sheet1").Range("F1").Value = "RET"
newbook.Worksheets("Sheet1").Range("G1").Value = "6"
newbook.Worksheets("Sheet1").Range("H1").Value = "PROD"
You can just use:
newbook.Worksheets("Sheet1").Range("A1:H1") = Array("ZHF", "CTO", "RET", "SupID", "RET", "RET", "6", "Prod")
I managed to resolve my issue using help from Here, to which I adapted to the code below and ran in a separate module, which allows for the use of a previously unspecified sheet name, that is later derived from a cell value. If the sheet does not exist, it is created matching the name to the stored value and the data pasted into it. Thanks for the support!
Sub TEST()
Dim i As Integer, blnFound As Boolean
blnFound = False
SupID = Trim(Sheets("Raw Data").Range("A2").Value)
Set myRng = Workbooks("Book1.xlsm").Worksheets("Raw Data").Range("B2:X7")
myRng.Copy
With ThisWorkbook
For i = 1 To .Sheets.Count
If .Sheets(i).Name = SupID Then
blnFound = True
.Sheets(i).Activate
ActiveSheet.Paste Destination:=Range("A" & LastRow + 1)
Exit For
End If
Next i
If blnFound = False Then
.Sheets.Add
With ActiveSheet
.Name = SupID
ActiveSheet.Paste Destination:=Range("A" & LastRow + 1)
End With
End If
End With
End Sub
I want to extract data from one speadsheet to another based on value of a particular cell.
I want to extract data to a new workbook based on Product. For example, Data for all the customer who purchased HDD should be moved to a new workbook and data for all customer who purchased monitor should be moved to another workbook. I 257 different product types, so data needs to be send to 257 different workbooks.
I was just wondering if there is any feature in excel through which we can search for value(Product in this senario) and move it to another worksheet.
Can anyone please help me regarding this?
Thanks in advance.
As tkacprow said there is no 'out of the box' tool that wil do this for you in excel. You will ideally need a VBA macro to do this.
I have just uploaded to my website an example tool/workbook which has the required VBA macro built into it. Feel free to utilise and change this to meet you needs http://tomwinslow.co.uk/handy-excel-tools/.
Let me know if this is not exactly what you are looking for and I can try amend it.
Hope this helps.
Below is the code incase you would prefer it, rather than downloading from my site.
Sub splitMasterList()
Dim MAST As Worksheet
Set MAST = Sheets("MASTER")
Dim headerRng As Range
Dim areaSelectionCount As Long
Dim areaSelectionIsValid As Boolean
Dim areaSelectionRow As Long
Dim splitColRng As Range
Dim themeExists As Boolean
Dim themeArray() As String
ReDim Preserve themeArray(1 To 1)
Dim lastRow As Long
Dim lastSheetTabRow As Long
Dim i As Long
Dim ii As Long
Dim theme As String
Dim doesSheetExist As Boolean
Dim ws As Worksheet
Dim sheetTabRowCounter As Long
'ask the user to highlight the table header
On Error Resume Next
Set headerRng = Application.InputBox(prompt:="Please select the headings of all columns that you wish to utilise." & vbNewLine & vbNewLine & "Note: Hold the 'Ctrl' key to select multiple ranges." & vbNewLine & vbNewLine, Default:="", Type:=8)
On Error GoTo 0
If headerRng Is Nothing Then
'notify user that the process cannot continue
' MsgBox "You must select a range to undertake this process."
'exit the sub
Exit Sub
End If
'check how many areas were selected and that they all have 1 row and are all on the same line
areaSelectionCount = headerRng.Areas.Count
areaSelectionIsValid = True
areaSelectionRow = 0
'loop through all areas checking they are a vald header
i = 1
For i = 1 To areaSelectionCount
'check selection area row count
If headerRng.Areas(i).Rows.Count <> 1 Then
areaSelectionIsValid = False
End If
'check selection area row
If areaSelectionRow = 0 Then
'set areaSelectionRow
areaSelectionRow = headerRng.Areas(i).Row
Else
'test areaSelectionRow variable against the row of the area selection
If areaSelectionRow <> headerRng.Areas(i).Row Then
areaSelectionIsValid = False
End If
End If
Next i
'exit if the area selection is not valid (FALSE)
If areaSelectionIsValid = False Then
'notify user that the process cannot continue
MsgBox "You may only select headings from a single row. Please try again."
'exit the sub
Exit Sub
End If
'ask the user to select the cell heading which they would like to plit their data on
On Error Resume Next
Set splitColRng = Application.InputBox("Select a cell from anywhere in the column which you want to use to classify (split) your data.", Default:="", Type:=8)
On Error GoTo 0
If splitColRng Is Nothing Then
'notify user that the process cannot continue
MsgBox "You must select a cell to undertake this process. Please start again."
'exit the sub
Exit Sub
End If
On Error GoTo errorHandling
'turn updating off
Application.ScreenUpdating = False
'loop down the master data and
lastRow = MAST.Cells(MAST.Rows.Count, "C").End(xlUp).Row
'loop down the items in the table and build an array of all themes (based on the user split cell selection)
For i = headerRng.Row + 1 To lastRow
'if the theme is blank then insert place holder
If MAST.Cells(i, splitColRng.Column).Value = "" Then
MAST.Cells(i, splitColRng.Column).Value = "Blank / TBC"
End If
'get the theme
theme = MAST.Cells(i, splitColRng.Column).Value
'check if the theme exists in the array yet
themeExists = False
ii = 1
For ii = 1 To UBound(themeArray)
If themeArray(ii) = theme Then
'stop loop and do not add current theme to the array
themeExists = True
End If
Next ii
If themeExists = False Then
'add current theme
themeArray(UBound(themeArray)) = MAST.Cells(i, splitColRng.Column).Value
ReDim Preserve themeArray(1 To UBound(themeArray) + 1)
End If
Next i
'notify the user how many themes there are going to be
' MsgBox "The table is about to be split into " & UBound(themeArray) - 1 & " seperate sheets, each containing grouped data based on the column you selected."
'loop through the theme array and build a :
'-sheet
'-table
'-rows
'for each theme
ii = 1
For ii = 1 To UBound(themeArray) - 1
'check if sheet exists
'check if a worksheet by the name of this theme exists and create one if not
'returns TRUE if the sheet exists in the workbook
doesSheetExist = False
For Each ws In Worksheets
If Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25) = ws.Name Then
doesSheetExist = True
End If
Next ws
'create sheet if it does not exist
If doesSheetExist = False Then
'create sheet after the master sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set ws = ActiveSheet
'max sheet name is 31 characters and cannot contain special characters
ws.Name = Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25)
Else
'do not creat sheet but activate the existing
Sheets(Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25)).Activate
Set ws = ActiveSheet
End If
'delete any old data out of the sheet
lastSheetTabRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
If lastSheetTabRow < 4 Then
lastSheetTabRow = 4
End If
ws.Rows("4:" & lastSheetTabRow).Delete Shift:=xlUp
'copy table header into each sheet tab
headerRng.Copy
ws.Range("B4").Select
ws.Paste
'insert title and time stamp details into new sheet
ws.Range("B2").Value = themeArray(ii)
ws.Range("B2").Font.Size = 22
ws.Range("B2").Font.Bold = True
ws.Range("B1").Font.Size = 8
ws.Range("C1:D1").Font.Size = 8
ws.Range("C1:D1").Cells.Merge
ws.Range("B1").Value = "Timestamp : "
ws.Range("C1").Value = Now()
ws.Range("C1").HorizontalAlignment = xlLeft
ws.Range("E1").Value = "Updates must NOT be done in this worksheet!"
ws.Range("E1").Font.Color = vbRed
'loop down the items in the master table and copy them over to the correct sheet tabs based on selected theme/column
sheetTabRowCounter = 1
i = headerRng.Row + 1
For i = headerRng.Row + 1 To lastRow
'copy item from master into theme tab if matches the theme
If MAST.Cells(i, splitColRng.Column).Value = themeArray(ii) Then
'copy row
MAST.Activate
headerRng.Offset(i - headerRng.Row, 0).Copy
'paste row
ws.Activate
ws.Cells(sheetTabRowCounter + 4, 2).Select
ws.Paste
'add one to the sheet row couter
sheetTabRowCounter = sheetTabRowCounter + 1
End If
Next i
Next ii
'format new sheet
'loop through all theme sheets and size their columns to match tre master sheet
ii = 1
For ii = 1 To UBound(themeArray) - 1
Sheets(Left(Replace(Replace(Replace(Replace(Replace(themeArray(ii), ",", ""), "/", ""), "\", ""), "[", ""), "]", ""), 25)).Activate
Set ws = ActiveSheet
'loop through all of the columns on the master table and get their size
i = headerRng.Column
For i = headerRng.Column To (headerRng.Column + headerRng.Columns.Count + 1)
ws.Columns(i).ColumnWidth = MAST.Columns(i).ColumnWidth
Next i
'loop down sheet tab and autofit all row heights
ws.Rows.AutoFit
ws.Columns("A").ColumnWidth = 2
ws.Activate
'hide gridlines
ActiveWindow.DisplayGridlines = False
'freeze panes
ActiveWindow.FreezePanes = False
ws.Cells(5, 1).Select
ActiveWindow.FreezePanes = True
ws.Range("A1").Select
Next ii
'loop through all sheets and delete sheets where the timestamp exists but is older than 5 seconds
For Each ws In Worksheets
'check if cell contains a date
If IsDate(ws.Range("C1").Value) = True And ws.Range("B1").Value = "Timestamp : " Then
'delete when sheet is older than 10 seconds
If (Now() - ws.Range("C1").Value) < 10 / 86400 Then
'MsgBox "OK - " & Now() - ws.Range("C1").Value
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next ws
Application.CutCopyMode = False
'activate the master sheet
MAST.Activate
MAST.Range("A1").Select
'turn updating back on
Application.ScreenUpdating = True
'notify user process is complete
MsgBox "Done!"
Exit Sub
errorHandling:
'notify the user of error
'activate the master sheet
MAST.Activate
MAST.Range("A1").Select
'turn updating back on
Application.ScreenUpdating = True
'notify user process is complete
MsgBox "Something went wrong! Please try again." & vbNewLine & vbNewLine & "Note: This error may be being caused by an invalid heading selection range." & vbNewLine & vbNewLine & "If the problem persists contact Tom Winslow for assistance."
End Sub
I do not suspect there is any out of the box "feature" to do this. However I would approach this as folows:
Sort the product by your category (so that all items going into a single workbook are line by line)
Do a simple VBA loop which: Checks if the product is of a new type. If yes then it should close the last open product workbook, create a new workbook e.g. using the name of the product, and saves the line to that workbook. If not then save the line to the current created and open workbook.
If you have problems with this VBA post it and we will help.
I'm attempting to write a macro to take an excel file of several thousand rows and split the inital sheet's rows up into sheets of 250 rows per-sheet, not including the original header row, which should also be copied to each sheet. There are 13 columns total, and some of the fields are empty.
I can sort the document myself - that's not an issue - I just don't have the macro skill to figure this one out.
I've tried searching, and found a few examples, but none quite fit..such as this one..
create macro that will convert excel rows from single sheet to new sheets ..or this one.. Save data input from one sheet onto successive rows in another sheet
Any help?
This should provide the solution you are looking for as well. You actually added your answer as I was typing it, but maybe someone will find it useful.
This method only requires that you enter the number of rows to copy to each page, and assumes you are on the "main" page once you execute it.
Sub AddSheets()
Application.EnableEvents = False
Dim wsMasterSheet As Excel.Worksheet
Dim wb As Excel.Workbook
Dim sheetCount As Integer
Dim rowCount As Integer
Dim rowsPerSheet As Integer
Set wsMasterSheet = ActiveSheet
Set wb = ActiveWorkbook
rowsPerSheet = 5
rowCount = Application.CountA(Sheets(1).Range("A:A"))
sheetCount = Round(rowCount / rowsPerSheet, 0)
Dim i As Integer
For i = 1 To sheetCount - 1 Step 1
With wb
'Add new sheet
.Sheets.Add after:=.Sheets(.Sheets.Count)
wsMasterSheet.Range("A1:M1").EntireRow.Copy Destination:=Sheets(.Sheets.Count).Range("A1").End(xlUp)
wsMasterSheet.Range("A" & (rowsPerSheet + 2) & ":M" & (2 * rowsPerSheet + 1)).EntireRow.Cut Destination:=Sheets(.Sheets.Count).Range("A" & Rows.Count).End(xlUp).Offset(1)
wsMasterSheet.Range("A" & (rowsPerSheet + 2) & ":M" & (2 * rowsPerSheet + 1)).EntireRow.Delete
ActiveSheet.Name = "Rows " + CStr(((.Sheets.Count - 1) * rowsPerSheet + 1)) & " - " & CStr((.Sheets.Count * rowsPerSheet))
End With
Next
wsMasterSheet.Name = "Rows 1 - " & rowsPerSheet
Application.EnableEvents = True
End Sub
#pnuts's suggested solution by Jerry Beaucaire worked perfectly.
https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/rows
Option Explicit
Sub SplitDataNrows()
'Jerry Beaucaire, 2/28/2012
'Split a data sheet by a variable number or rows per sheet, optional titles
Dim N As Long, rw As Long, LR As Long, Titles As Boolean
If MsgBox("Split the activesheet into smaller sheets?", vbYesNo, _
"Confirm") = vbNo Then Exit Sub
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
If N = 0 Then Exit Sub
If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
"Titles?") = vbYes Then Titles = True
Application.ScreenUpdating = False
With ActiveSheet
LR = .Range("A" & .Rows.Count).End(xlUp).Row
For rw = 1 + ---Titles To LR Step N
Sheets.Add
If Titles Then
.Rows(1).Copy Range("A1")
.Range("A" & rw).Resize(N).EntireRow.Copy Range("A2")
Else
.Range("A" & rw).Resize(N).EntireRow.Copy Range("A1")
End If
Columns.AutoFit
Next rw
.Activate
End With
Application.ScreenUpdating = True
End Sub
--
Option Explicit
Sub SplitWorkbooksByNrows()
'Jerry Beaucaire, 2/28/2012
'Split all data sheets in a folder by a variable number or rows per sheet, optional titles
'assumes only one worksheet of data per workbook
Dim N As Long, rw As Long, LR As Long, Cnt As Long, Cols As String, Titles As Boolean
Dim srcPATH As String, destPATH As String, fNAME As String, wbDATA As Workbook, titleRNG As Range
srcPATH = "C:\Path\To\Source\Files\" 'remember the final \ in this string
destPATH = "C:\Path\To\Save\NewFiles\" 'remember the final \ in this string
'determine how many rows per sheet to create
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
If N = 0 Then Exit Sub 'exit if user clicks CANCEL
'Examples of usable ranges: A:A A:Z C:E F:F
Cols = Application.InputBox("Enter the Range of columns to copy", "Columns", "A:Z", Type:=2)
If Cols = "False" Then Exit Sub 'exit if user clicks CANCEL
'prompt to repeat row1 titles on each created sheet
If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
"Titles?") = vbYes Then Titles = True
Application.ScreenUpdating = False 'speed up macro execution
Application.DisplayAlerts = False 'turn off system alert messages, use default answers
fNAME = Dir(srcPATH & "*.xlsx") 'get first filename from srcPATH
Do While Len(fNAME) > 0 'exit loop when no more files found
Set wbDATA = Workbooks.Open(srcPATH & fNAME) 'open found file
With ActiveSheet
LR = Intersect(.Range(Cols), .UsedRange).Rows.Count 'how many rows of data?
If Titles Then Set titleRNG = Intersect(.Range(Cols), .Rows(1)) 'set title range, opt.
For rw = 1 + ---Titles To LR Step N 'loop in groups of N rows
Cnt = Cnt + 1 'increment the sheet creation counter
Sheets.Add 'create the new sheet
If Titles Then titleRNG.Copy Range("A1") 'optionally add the titles
'copy N rows of data to new sheet
Intersect(.Range("A" & rw).Resize(N).EntireRow, .Range(Cols)).Copy Range("A1").Offset(Titles)
ActiveSheet.Columns.AutoFit 'cleanup
ActiveSheet.Move 'move created sheet to new workbook
'save with incremented filename in the destPATH
ActiveWorkbook.SaveAs destPATH & "Datafile_" & Format(Cnt, "00000") & ".xlsx", xlNormal
ActiveWorkbook.Close False 'close the created workbook
Next rw 'repeat with next set of rows
End With
wbDATA.Close False 'close source data workbook
fNAME = Dir 'get next filename from the srcPATH
Loop 'repeat for each found file
Application.ScreenUpdating = True 'return to normal speed
MsgBox "A total of " & Cnt & " data files were created." 'report
End Sub