I am attempting to loop through data in a sheet and split them on a comma, when I run the script I get a Run Time Error '1004' Application-Defined or Object defined error.
However, When I step into the script to debug and run it step by step it works perfectly. I was wondering if anyone has seen this and could help me in fixing it.
Sub PopulatePayrollForm()
Dim s As String: s = "Payout Review"
If DoesSheetExists(s) Then
Dim BottomRow As Long
Dim c As Range
Dim splitv() As String
Sheets("Pay Form").Range("A6:AR1000").ClearContents
'Copy to another sheet, Split Columns, Copy and paste full name into 2 cells
Worksheets("Payout Review").Range("A2:A1000").Copy Worksheets("Pay Form").Range("AQ6:AQ1006")
BottomRow = Worksheets("Pay Form").Cells(Rows.Count, "AQ").End(xlUp).Row
Worksheets("Pay Form").Range("AQ6:AQ" & BottomRow).Activate
For Each c In Selection
splitv = Split(c.Value, ",")
If UBound(splitv) > 0 Then
c.Offset(0, -1).Value = splitv(1)
c.Offset(0, -1).Value = c.Offset(0, -1).Value
c.Value = splitv(0)
End If
Next c
Worksheets("Pay Form").Range("AP6:AQ" & BottomRow).Copy Worksheets("Pay Form").Range("C6:C" & BottomRow)
Worksheets("Pay Form").Range("AP6:AQ" & BottomRow).Clear
'Copy and paste Employee Id, Payout AMount, Date Range
Worksheets("Payout Review").Range("B2:B1000").Copy Worksheets("Pay Form").Range("A6:A" & BottomRow)
Worksheets("Payout Review").Range("AB2:AB1000").Copy
Sheets("Pay Form").Range("B6:B" & BottomRow).PasteSpecial xlPasteValues
Worksheets("Payout Review").Range("AD1").Copy Worksheets("Pay Form").Range("J6:J" & BottomRow)
Worksheets("Payout Review").Range("AE1").Copy Worksheets("Pay Form").Range("K6:K" & BottomRow)
Sheets("Pay Form").Visible = True
Else
MsgBox "Data Does not exist"
End If
End Sub
Function DoesSheetExists(sh As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sh)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function
The problem is the use of Selection (and Activate):
For Each c In Selection
Just use the Range in question:
For Each c In Worksheets("Pay Form").Range("AQ6:AQ" & BottomRow)
I recommend reading this for a comprehensive discussion of how to avoid Select.
Related
I am working to create an add on style sheet to my company timesheet that will autofill company paid holidays by just the user inserting the dates. I use formulas on the excel timesheets to autofill the dates for the entire year so that I save time doing my bi-weekly payroll form. I have a holiday sheet that I name the holidays and input the date they are observed. The code is supposed to search all worksheets in the workbook until it finds the date for the corresponding holiday and input the number of hours off, the holiday code and name. The code I have written will find any date I insert up to 11/9/2022 and after this date it will not find any further dates. I have tried many things including changing the date column format, using different criteria settings for the .Find and even removing the formula from the date column and actually writing in 11/11/2022 and it is still unable to locate the date while using .Find. Please any help would be appreciated. I have added a few screens and code snippets of what I have so far.
Sub VeteransDay()
Dim ws As Worksheet
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Holiday").Range("B9").Value
If Trim(FindString) <> "" Then
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
With ws.UsedRange
Set Rng = .Find(What:=FindString, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
If Not Rng Is Nothing Then
sheetName = ws.Name
Cell_Add = Split(Rng.Address, "$")
ThisCol = Cell_Add(1)
ThisRow = Cell_Add(2)
Worksheets(sheetName).Range("K" & ThisRow).Value = 8
Worksheets(sheetName).Range("K" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("L" & ThisRow).Value = "HD"
Worksheets(sheetName).Range("L" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("M" & ThisRow).Value = Range("A9")
Worksheets(sheetName).Range("M" & ThisRow).Font.Color = vbRed
Exit Sub
End If
End With
End If
Next ws
End If
End Sub
enter image description here
enter image description here
Try this, the search is restricted to the range B1:B37 on each sheet.
Option Explicit
Sub VeteransDay()
Dim ws As Worksheet, ar, r
Dim dt As Date, sName As String, n As Long
Dim arHoliday, lastrow As Long, i As Long
With Sheets("Holiday")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
arHoliday = .Range("A1:B" & lastrow).Value
End With
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
' loop through holidays
For i = 1 To UBound(arHoliday)
dt = arHoliday(i, 2)
r = Application.Match(CDbl(dt), ws.Range("B1:B37").Value2, 0)
If Not IsError(r) Then
'MsgBox ws.Name & " row " & r
With ws.Range("K" & r)
.Value = 8
.Offset(, 1) = "HD"
.Offset(, 2) = arHoliday(i, 1) ' col A
.Resize(, 3).Font.Color = vbRed
n = n + 1
End With
End If
Next
End If
Next ws
MsgBox n & " found for all dates", vbInformation
End Sub
I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
I would like to convert a Pivot Table to a sum if statement using a VBA macro.
I found one which used to work on Excel 2016 (https://www.excelcampus.com/vba/convert-pivot-table-to-sumifs-formulas-vba-macro/) since I went to 0365, the macro is not working.
I tried to fix the code myself but got stuck on the line
Set rSource = Application.Evaluate(Application.ConvertFormula(PivotTable.SourceData, xlR1C1, xlA1))
which led to a #424 error object needed.
Any ideas would be gratefully accepted!
The whole code is the following`and the error seems to come from the function part:
Option Explicit
Dim pvt As PivotTable
Dim rSource As Range
Dim wsSource As Worksheet
Dim bTable As Boolean
Dim pi As PivotItem
Dim pc As PivotCell
Dim pf As PivotField
Dim wsNew As Worksheet
Dim wsPivot As Worksheet
Dim c As Range
Dim lFunction As Long
Dim sSumRange As String
Dim sCritRange As String
Dim sCriteria As String
Dim sFormula As String
Dim sFormulaPage As String
Dim sSearchField As String
Dim sDataSheet As String
Dim lDataRows As Long
Dim sPageRange As String
Dim lCol As Long
Dim bArray As Boolean
Dim sTableName As String
Dim sFormulaArgs As String
Dim sFormulaCnt As String
Dim lLblRow As Long
Dim lLblCol As Long
Dim sFilter As String
Dim sDataField As String
Dim bReturn As Boolean
Sub Convert_Pivot_to_Formulas()
'---------------------------------------------------------------------------------------
' Procedure : Convert_Pivot_to_Formulas
' Author : Jon Acampora, Excel Campus LLC, www.excelcampus.com
' Date : 10/13/2014
' Purpose : Creates a copy of the selected pivot table on a new sheet and converts
' all cells in the values area to SUMIFS, COUNTIFS, or AVERAGEIFS formulas
' Details : The following is a list of features, requirement, and limitations of the macro.
' Features
' - Works with page fields with multiple items in filter of one page field.
' Creates the page field criteria across columns and creates array formulas.
' Requirements
' - Fields in the pivot containing dates must be in the same format as the source data.
' - Source data must be in same workbook. This can be expaned to ref source data in other workbooks.
' Limitations
' - Does not work with grouped date fields. The criteria ranges do NOT exist in the source data.
' Create the date group fields as columns in the source data to solve this issue.
'---------------------------------------------------------------------------------------
'Set pivot table variables
On Error Resume Next
Set pvt = ActiveCell.PivotTable
Set wsPivot = ActiveSheet
On Error GoTo 0
If pvt Is Nothing Then
MsgBox "Please select a Pivot Table first.", vbOKOnly, "Convert Pivot to Formula Error"
Exit Sub
End If
'Check if source data is in the same workbook.
If Get_Pivot_Source Then
On Error GoTo Err_Handle
'-------------------------------------------------------
'1. Create new sheet with shell of pivot table - filter, rows, columns areas
'-------------------------------------------------------
Set wsNew = Worksheets.Add(after:=ActiveSheet)
sDataSheet = wsSource.Name
lDataRows = rSource.Rows.Count
If bTable Then sTableName = pvt.SourceData
'Copy pivot table values to new sheet
wsPivot.Select
wsPivot.Range(pvt.TableRange1.Address).Copy
With wsNew.Range(pvt.TableRange1.Address)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
If pvt.PageFields.Count > 0 Then
wsPivot.Range(pvt.PageRange.Address).Copy
With wsNew.Range(pvt.PageRange.Address)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
End If
'-------------------------------------------------------
'2. Add page field filters across columns in new sheet
'-------------------------------------------------------
If pvt.PageFields.Count > 0 Then
For Each pf In pvt.PageFields
sPageRange = pf.LabelRange.Offset(, 1).Resize(1, 1).Address
sFilter = pf.LabelRange.Offset(, 1).Resize(1, 1).Value
lCol = 0 'offset 1 col to the right
Select Case sFilter
Case "(All)"
'skip
Case "(Multiple Items)"
'Loop pivot items and add selected items to page range across columns
For Each pi In pf.PivotItems
If pi.Visible Then
wsNew.Range(sPageRange).Offset(, lCol).Resize(1, 1).Value = pi.Name
lCol = lCol + 1
End If
Next pi
Case Else 'One item selected
lCol = 1
wsPivot.Range(sPageRange).Offset(, lCol).Resize(1, 1).Value = wsNew.Range(sPageRange).Offset(, lCol).Resize(1, 1).Value
End Select
'Create string for formula
If lCol > 0 Then 'filters exist
If bTable Then
sCritRange = sTableName & "[" & pf.Name & "]"
Else
sSearchField = pf.Name
sCritRange = "'" & sDataSheet & "'!" & rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
End If
sCriteria = wsNew.Range(sPageRange).Resize(1, lCol).Address
sFormulaPage = sFormulaPage & "," & sCritRange
sFormulaPage = sFormulaPage & "," & sCriteria
End If
'IFS formula will have to be an array if there are multiple critera (range) in criteria argument
If lCol > 1 Then bArray = True
Next pf
End If
'-------------------------------------------------------
'3. Loop through each cell in values area to build formula.
'-------------------------------------------------------
For Each c In pvt.DataBodyRange.Cells
Set pc = c.PivotCell
sFormula = ""
sFormulaArgs = ""
'-------------------------------------------------------
'4. Create SUM RANGE reference for formula
'-------------------------------------------------------
'Check if function is sum, count, or average
If pc.PivotField.Function = xlSum Or pc.PivotField.Function = xlCount Or pc.PivotField.Function = xlAverage Then
'Count the criteria, if 0 then it's a total and no IFS needed
sCriteria = ""
'Add column items to filter array
If pc.PivotCellType = xlPivotCellValue Then
sDataField = pc.PivotField.SourceName
lFunction = pc.PivotField.Function
'Add Sum Range
lFunction = pc.PivotField.Function
If bTable Then
sSumRange = sTableName & "[" & pc.PivotField.SourceName & "]"
Else
sSearchField = pc.PivotField.SourceName
sSumRange = "'" & sDataSheet & "'!" & rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
End If
'-------------------------------------------------------
'5. Loop through ROW items of pivotcell and add row refs to formula
'-------------------------------------------------------
If pc.RowItems.Count Then
For Each pi In pc.RowItems
If bTable Then
sCritRange = sTableName & "[" & pi.Parent.Name & "]"
Else
sSearchField = pi.Parent.Name
sCritRange = "'" & sDataSheet & "'!" & rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
End If
'Find the address of the pivotcells labelrange for the criteria address
'Start from the current row and loop up through the label range until the
'pivotitem name is found. Required due to variety of pivot table layouts.
lLblCol = pi.LabelRange.Column
For lLblRow = c.Row To pi.Parent.LabelRange.Row + 1 Step -1
If Cells(lLblRow, lLblCol).Value = pi.Name Then
sCriteria = Cells(lLblRow, pi.LabelRange.Column).Address
Exit For
End If
Next lLblRow
If sCriteria <> "" Then
sFormulaArgs = sFormulaArgs & "," & sCritRange
sFormulaArgs = sFormulaArgs & "," & sCriteria
End If
sCriteria = ""
Next pi
End If
'-------------------------------------------------------
'6. Loop through COLUMN items of pivotcell and add row refs to formula
'-------------------------------------------------------
If pc.ColumnItems.Count Then
For Each pi In pc.ColumnItems
If bTable Then
sCritRange = sTableName & "[" & pi.Parent.Name & "]"
Else
sSearchField = pi.Parent.Name
sCritRange = "'" & sDataSheet & "'!" & rSource.Resize(1).Find(What:=sSearchField, LookAt:=xlWhole).Offset(1).Resize(lDataRows - 1, 1).Address
' If sCritRange Is Nothing Then
' On Error GoTo 0
' Else
' End If
End If
'Find the address of the pivotcells labelrange for the criteria address
'Start from the current column and loop back left through the label range until the
'pivotitem name is found. Required due to variety of pivot table layouts.
lLblRow = pi.LabelRange.Row
For lLblCol = c.Column To pi.LabelRange.Column Step -1
If Cells(lLblRow, lLblCol).Value = pi.Name Then
sCriteria = Cells(pi.LabelRange.Row, lLblCol).Address
Exit For
End If
Next lLblCol
If sCriteria <> "" Then
sFormulaArgs = sFormulaArgs & "," & sCritRange
sFormulaArgs = sFormulaArgs & "," & sCriteria
End If
sCriteria = ""
Next pi
End If
'-------------------------------------------------------
'7. Build Formula based on function type of pivotcell
'-------------------------------------------------------
Select Case pc.PivotField.Function
Case xlSum
If sFormulaArgs = "" And sFormulaPage = "" Then 'Don't need IFS when there are no criteria (total rows/columns)
sFormula = "=SUM(" & sSumRange & ")"
Else
If bArray Then
sFormula = "=SUM(SUMIFS(" & sSumRange & sFormulaPage & sFormulaArgs & "))"
Else
sFormula = "=SUMIFS(" & sSumRange & sFormulaPage & sFormulaArgs & ")"
End If
End If
Case xlCount
If sFormulaArgs = "" And sFormulaPage = "" Then 'Don't need IFS when there are no criteria (total rows/columns)
sFormula = "=COUNT(" & sSumRange & ")"
Else
sFormulaCnt = sFormulaPage & sFormulaArgs 'Don't need sum range for countifs
sFormulaCnt = Right(sFormulaCnt, Len(sFormulaCnt) - 1) 'trim preceding comma
If bArray Then
sFormula = "=SUM(COUNTIFS(" & sFormulaCnt & "))"
Else
sFormula = "=COUNTIFS(" & sFormulaCnt & ")"
End If
End If
Case xlAverage
If sFormulaArgs = "" And sFormulaPage = "" Then 'Don't need IFS when there are no criteria (total rows/columns)
sFormula = "=AVERAGE(" & sSumRange & ")"
Else
sFormula = "=AVERAGEIFS(" & sSumRange & sFormulaPage & sFormulaArgs & ")" 'AVERAGEIFS not working with array formula, returns errors
End If
End Select
'-------------------------------------------------------
'8. Add formula to new sheet
'-------------------------------------------------------
If bArray Then
If Len(sFormula) < 255 Then
wsNew.Range(c.Address).FormulaArray = sFormula
Else
'.FormulaArray hits an error if formula string is > 255 characters
'Add error handling here
End If
Else
wsNew.Range(c.Address).Formula = sFormula
End If
End If
End If
Next c
End If
wsNew.Select
Exit Sub
Err_Handle:
MsgBox Err.Description & vbNewLine & "Current Cell: " & c.Address, _
vbCritical, "Convert Pivot to Formulas Error"
End Sub
Function Get_Pivot_Source() As Boolean
'Determine if source is a cell reference, named range, or Excel Table
'Set source range variables
'Consider using the PivotCache.SourceType property to check this.
'http://msdn.microsoft.com/en-us/library/office/ff194557.aspx
'On Error GoTo Err_Handler
'Set variables for selected pivot table
bReturn = False
Set rSource = Nothing
Set wsSource = Nothing
Set pvt = ActiveCell.PivotTable
Set wsPivot = ActiveSheet
bTable = False
If ActiveCell.PivotTable.PivotCache.SourceType = xlDatabase Then
If InStr(ActiveCell.PivotTable.SourceData, "[") = 0 Then 'check if source data contains workbook name - bypass external source range - Temp TO DO
If InStr(ActiveCell.PivotTable.SourceData, ":") > 0 Then 'if data source range is a cell ref range
Set rSource = Application.Evaluate(Application.ConvertFormula(ActiveCell.PivotTable.SourceData, fromReferenceStyle:=xlR1C1, toReferenceStyle:=xlA1))
Else 'if Table or Named Range are used as data source range
Set rSource = Range(pvt.SourceData)
On Error GoTo SkipTable 'check if the data source name is a table
Set rSource = Range(pvt.SourceData & "[#All]")
bTable = True
SkipTable:
On Error GoTo 0
End If
Set wsSource = rSource.Parent
bReturn = True
End If
End If
Get_Pivot_Source = bReturn
Exit Function
Err_Handler:
MsgBox "Error in Get_Source_Range procedure."
Get_Pivot_Source = False
End Function
I have a text string that is using the ^ symbol as a delimiter.
I need to separate the text into new rows rather than new columns.
I need to create new rows to not overwrite the next line of data below it.
Is this possible without using a macro? I'm not against using one, I just wouldn't know where to start to write it.
Below is a pic of some sample data. The top part is how it's listed, and the bottom (in yellow) is how I would like it.
Using Excel 2010 on Windows 7 Pro.
Thanks to those that responded. A friend was able to help by providing the following code:
Sub Breakout()
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
For r = LR To 2 Step -1
Set MyCell = Cells(r, 1)
Arry = Split(MyCell.Value, "^")
For c = 0 To UBound(Arry)
If c > 0 Then MyCell.Offset(c, 0).EntireRow.Insert
MyCell.Offset(c, 0) = Arry(c)
Next c
Next r
End Sub
Could try something like this:
Sub reArrange()
Dim inFirstRng As Range
Dim inRng As Range
Dim inCur As Variant
Dim outFirstRng As Range
Dim outCurRng As Range
Dim ws As Worksheet
'CHANGE ARGUMENT TO YOUR SHEET NAME
Set ws = Worksheets("Sheet2")
With ws
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA INPUT IS IN COLUMN A
Set inFirstRng = .Range("A3")
Set inRng = .Range(inFirstRng, inFirstRng.End(xlDown))
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA OUTPUT IS IN COLUMN A
Set outFirstRng = .Range("A9")
Set outCurRng = outFirstRng
End With
For Each cell In inRng.Cells
inCur = WorksheetFunction.Transpose(Split(cell.Value, "^"))
outCurRng.Resize(UBound(inCur), 1).Value = inCur
With ws
.Range("G" & outCurRng.Row & ":L" & outCurRng.Row).Value = _
.Range("G" & cell.Row & ":L" & cell.Row).Value
End With
Set outCurRng = outCurRng.Offset(UBound(inCur), 0)
Next cell
ws.Range("F" & outFirstRng.Row & ":F" & outCurRng.Row - 1).Value = 1
End Sub
I’m a complete newbie with VBA but have managed to cobble together the following which works fine for my worksheet where I have assigned the code to a command button. My problem is that my worksheet has in excess of 3000 rows and I don’t really want to create 3000 buttons.
My current thinking would be to have a script search a range of cells for a specific condition (i.e. TRUE) then run my original code as a subscript for each cell that matches the condition. I have tried creating a loop to match the condition being searched but don't know how to set the result(s) as an active cell.
Could anyone give me some pointer on how to achieve this or propose a better solution?
Thanks.
Sub Send_FWU_to_E_Drive()
Dim aTemp As String
Dim bTemp As String
Dim cTemp As String
Dim dTemp As String
Dim eTemp As String
Dim subdir As String
aTemp = "c:\test\"
bTemp = "E:\romdata\"
cTemp = ActiveCell.Offset(, -5) & ".fwu"
dTemp = ActiveWorkbook.path
eTemp = "\Firmware files"
subdir = "\Firmware Files\" & ActiveCell.Offset(, -5) & "\" & ActiveCell.Offset(, -5) & ".fwu"
MsgBox "The path of the active workbook is " & dTemp & subdir
If Dir(dTemp & subdir) = "" Then
MsgBox "Please check the file and ensure it is suitable for firmware updating with an SD card."
Exit Sub
End If
MsgBox "The file " & cTemp & " is being copied to " & bTemp
If Dir("e:\romdata", vbDirectory) = "" Then MkDir "E:\romdata"
If Dir(bTemp & "nul") = "" Then
MsgBox "The Destination Directory is missing, please ensure your SD Card is formatted, mapped as drive E and has a romdata directory."
Exit Sub
End If
FileCopy dTemp & subdir, bTemp & cTemp
End Sub
First modify your function to accept a range argument, which we'll call cell:
Sub Send_FWU_to_E_Drive(cell as Excel.Range)
Then change all the ActiveCell references in that Sub to cell.
The sub below loops through each cell in column B of the Active sheet and, if it's TRUE, calls your routine with the cell in column A of that row. So your offsets in the code in Send_FWU_to_E_Drive are all relative to the cell in column A. This code is untested, but should be close:
Sub Test
Dim Cell as Excel.Range
Dim LastRow as Long
With ActiveSheet
LastRow = .Range("A" & .Rows.Count).End(xlup).Row
For Each Cell in .Range("B2:B" & LastRow) 'Search for TRUE in column B
If Cell.Value = TRUE Then
Send_FWU_to_E_Drive cell.Offset(0,-1) 'Column A Cell
End If
Next Cell
End With
End Sub
EDIT: Per #Siddharth's suggestion, here's a Find/FindNext version:
Sub Test()
Dim cell As Excel.Range
Dim LastRow As Long
Dim SearchRange As Excel.Range
Dim FirstFindAddress As String
With ActiveSheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set SearchRange = .Range("B2:B" & LastRow) 'Search for TRUE in column B
Set cell = SearchRange.Find(what:=True, after:=SearchRange.Cells(1))
If Not cell Is Nothing Then
FirstFindAddress = cell.Address
Send_FWU_to_E_Drive cell.Offset(0, -1)
Do
Send_FWU_to_E_Drive cell.Offset(0, -1)
Set cell = SearchRange.FindNext(after:=cell)
Loop While Not cell Is Nothing And cell.Address <> FirstFindAddress
End If
End With
End Sub