Good Day,
I am trying to add a column on the sheet that I am creating including the formula of the selected column.
As per checking surfing for some codes I saw this,
Sub InsertRows()
Dim Rng As Long
Dim lngA As Long
Dim lngB As Long
Application.ScreenUpdating = False
Rng = InputBox("Enter number of rows required.")
If Rng = 0 Then Exit Sub
Range(ActiveCell.Offset(1), ActiveCell.Offset(Val(Rng), 0)).EntireRow.Insert
'// How many formulas To copy down?
'// From A To last entry In row.
lngB = ActiveCell.Row
lngA = Cells(lngB, Columns.Count).End(xlToLeft).Column
Range(Cells(lngB, 1), Cells(lngB + Val(Rng), lngA)).FillDown
this code really suits my need, however after trying several times, i am not able to convert it as column function. may I ask for your help to convert this?
thank you so much
Best regards,
Check this out:
Sub InsertCols()
Dim Rng As Long
Application.ScreenUpdating = False
Rng = InputBox("Enter number of rows required.")
If Rng = 0 Then Exit Sub
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, Val(Rng))).EntireColumn.Insert
ActiveCell.EntireColumn.Copy
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, Val(Rng))).EntireColumn.PasteSpecial xlPasteAll
Application.CutCopyMode = False
End Sub
Related
I am attempting to use VBA to fill all blank cells in rows with the value to the left, with the exception that I only want to fill the blank cells between the first and last value in the row (not including row 1 and column A, which are identifiers).
I've struggled with getting the loop to stop once the last column with a value has been reached (as this changes with each row), rather than running all the way through the last column on the sheet.
Originally this was marked as duplicate (Autofill when there are blank values), but this does not solve the mentioned problem. This continues until the sheet ends. As seen in the picture below, the fill should stop when the last value is reached.
I am searching for a solution that will allow me to do this for an entire sheet at once, even though the data ends in different columns throughout the sheet. There are 1000+ rows, so running for each row could be quite tedious.
I've been using this code to fill the data (excluding the 1st row and column). But this is where I am not sure how to get it to stop at the last value in the row.
Sub test()
With ThisWorkbook.Sheets("Sheet1").Range("A:A")
With Range(.Cells(2, 2), .Cells(.Rows.Count, 36).End(xlUp))
With .Offset(0, 1)
.Value = .Value
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC[-1]&"""""
On Error GoTo 0
.Value = .Value
End With
End With
End With
End Sub
If my explanation was not clear, This is a sample and the output I am trying to create
Thank you all so much in advance for all your help!
You may try something like this...
Sub FillBlanks()
Dim r As Long, lr As Long, lc As Long
Dim cell As Range, FirstCell As Range, LastCell As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(2, Columns.Count).End(xlToLeft).Column
For r = 3 To lr
Set FirstCell = Range(Cells(r, 1), Cells(r, lc)).Find(what:="*", after:=Cells(r, 1))
If Not FirstCell Is Nothing And FirstCell.Column > 1 Then
Set LastCell = Cells(r, Columns.Count).End(xlToLeft)
Range(FirstCell, LastCell).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC[-1]"
Range(FirstCell, LastCell).Value = Range(FirstCell, LastCell).Value
End If
Next r
End Sub
And here is yet another solution (just to give you some variety):
Option Explicit
Sub fillInTheBlanks()
Dim lngRow As Long
Dim ws As Worksheet
Dim lngColumn As Long
Dim bolStart As Boolean
Dim lngLastColumn As Long
Dim dblTempValue As Double
Dim arrSheetCopy As Variant
Set ws = ThisWorkbook.Worksheets("Sheet1")
arrSheetCopy = ws.Range(ws.Cells(3, 1), ws.Cells(ws.Cells(ws.Rows.Count, "A").End(xlUp).Row, ws.UsedRange.Columns.Count)).Value2
For lngRow = LBound(arrSheetCopy, 1) To UBound(arrSheetCopy, 1)
bolStart = False
lngLastColumn = 0
For lngColumn = LBound(arrSheetCopy, 2) To UBound(arrSheetCopy, 2)
If Not arrSheetCopy(lngRow, lngColumn) = vbEmpty Then lngLastColumn = lngColumn
Next lngColumn
For lngColumn = LBound(arrSheetCopy, 2) To lngLastColumn
If arrSheetCopy(lngRow, lngColumn) = vbEmpty And bolStart Then
arrSheetCopy(lngRow, lngColumn) = dblTempValue
Else
If Not arrSheetCopy(lngRow, lngColumn) = vbEmpty And IsNumeric(arrSheetCopy(lngRow, lngColumn)) Then
bolStart = True
dblTempValue = CDbl(arrSheetCopy(lngRow, lngColumn))
End If
End If
Next lngColumn
Next lngRow
ws.Range("A3").Resize(UBound(arrSheetCopy, 1), UBound(arrSheetCopy, 2)).Value2 = arrSheetCopy
End Sub
This one is probably the fastest solution (even though it seems a bit bulky with much more lines of code when compared to the other solutions). That's due to the fact that this solution is doing most of the work in memory and not on the sheet. The entire sheet is loaded into a variable and then the work is done on the variable before the result (the variable) is written back to the sheet. So, if you have a speed problem then you might want to consider using this solution.
Here is one possible that meets your sample data's expectations.
Sub wqewqwew()
Dim i As Long, fc As Variant, lc As Long
'necessary if you do not want to confirm numbers and blanks in any row
On Error Resume Next
With ThisWorkbook.Worksheets("Sheet6")
For i = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
If CBool(Application.Count(Rows(i))) Then
fc = Intersect(.Rows(i), .UsedRange).Offset(0, 1).SpecialCells(xlCellTypeConstants, xlNumbers).Cells(1).Column
If Not IsError(fc) Then
lc = Application.Match(9 ^ 99, .Rows(i))
On Error Resume Next
With .Range(.Cells(i, fc), .Cells(i, lc))
.SpecialCells(xlCellTypeBlanks).Cells.FormulaR1C1 = "=RC[-1]"
.Value = .Value2
End With
End If
End If
Next i
End With
End Sub
Just another solution:
The following code can help is there you need to auto-fill the previous values between 1st and last cells depending on value of 1st cell as mentioned in question Excel - VBA fill in cells between 1st and Last value
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
For i = 2 To Target.Column
If Cells(Target.Row, i) = "" Then
If Cells(Target.Row, i - 1) <> "" Then
Range(Cells(Target.Row, i), Cells(Target.Row, i)).Value = Range(Cells(Target.Row, i - 1), Cells(Target.Row, i - 1)).Value
End If
End If
Next i
End Sub
This sub is activated by clicking on any cell. Same cell marks the end of the loop i.e. to stop the loop just click the cell till which you want to fill the blank cells.
I have the below code that will filter the table by the user selection.
I would like to first check range A3:T3 if they have values in and if they do i will add to my array and start filtering by that and ignore all empty cells in Range A3:T3.
If range A3:T3 is empty then filter by user selection.
I notice there is a bug where if i filter by a cell and that cell has 2 rows with data 1 will show and 1 not because there is a space in front of it i think its a ChrW is there any way to make the filter take partial match to include both versions? I know i can replace the ChrW and replace it but data will be always pasted from outlook so the occurrence will be frequent so if i can take a partial match that will probably solve a lot of the problems.
Any help would be much appreciated.
Sub advancedMultipleCriteriaFilter()
Dim cellRng As Range, tableObject As Range, subSelection As Range
Dim filterCriteria() As String, filterFields() As Integer
Dim i As Integer
Application.ScreenUpdating = False
'Call removeSpace
If Selection.Rows.Count > 1 Then
MsgBox "Cannot apply filter to multiple rows within the same column. Please make another selection and try again.", vbInformation, "Selection Error!"
Exit Sub
End If
i = 1
ReDim filterCriteria(1 To Selection.Cells.Count) As String
ReDim filterFields(1 To Selection.Cells.Count) As Integer
Set tableObject = Selection.CurrentRegion
For Each subSelection In Selection.Areas
For Each cellRng In subSelection
filterCriteria(i) = cellRng.Text
filterFields(i) = cellRng.Column - tableObject.Cells(1, 1).Column + 1
i = i + 1
Next cellRng
Next subSelection
With tableObject
For i = 1 To UBound(filterCriteria)
.AutoFilter field:=filterFields(i), Criteria1:=filterCriteria(i)
Next i
End With
Call GetLastRow
Set tableObject = Nothing
Application.ScreenUpdating = True
End Sub
Sub resetFilters()
Dim sht As Worksheet
Dim LastRow As Range
Application.ScreenUpdating = False
On Error Resume Next
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Range("A3:T3").ClearContents
Application.ScreenUpdating = True
Call GetLastRow
End Sub
Private Sub GetLastRow()
'Step 1: Declare Your Variables.
Dim LastRow As Long
'Step 2: Capture the last used row number.
LastRow = Cells(Rows.Count, 8).End(xlUp).Row
'Step 3: Select the next row down
Cells(LastRow, 8).Offset(1, 0).Select
End Sub
If you want to filter multi-criteria in a single field, you will need array as below:
.AutoFilter Field:=1, Criteria1:=Array("val 2", "val 3", "val 4"), Operator:=xlFilterValues
so filterCriteria(i) must be an Array, you can just do it as below:
filterCriteria(i) = Array("item1","item2")
.AutoFilter Field:=filterFields(i), Criteria1:=filterCriteria(i), Operator:=xlFilterValues
I'm currently building a VBA code to actively define the range for a graph.
Sub ABC()
Dim count As Integer
Dim countAll As Integer
Dim i As Integer
Dim j As Integer
Dim filter As Variant
Dim exfilter As Variant
Dim ws As Worksheet
Set ws = Worksheets(1)
Dim n As Integer
'Cancel updating
Application.ScreenUpdating = False
'Clear oldsheet
Sheets("FLAGGED rest # list").Activate
Range("a3:a9999").ClearContents
'Autofilter sheet and copy range
Sheets("restaurant performance 2016").Activate
Range("a7:ah7").Select
Selection.AutoFilter
ActiveSheet.Range("$A$7:$AH$510").AutoFilter Field:=11, Criteria1:="<>"
ActiveSheet.AutoFilter.Range.Copy
'Paste to new sheet
Sheets("FLAGGED rest # list").Activate
Cells(2, 1).Select
ActiveSheet.Paste
'
'Clean out irrelevant data
Range("b2:az9999").Clear
'Count number of restaurants
Sheets("flagged rest # list").Activate
Cells(3, 1).Select
Sheets("flagged rest # list").Range(Selection, Selection.End(xlDown)).Select
count = Application.WorksheetFunction.CountA(Selection)
'Count number of weeks
Sheets("12 week trend").Activate
Cells(2, 2).Select
'Create Chart
n = 2 + count
rangestring = "$C$3:$O$" & n
rangestring2 = "'12 week trend'!" & rangestring
Sheets("12 week trend").Activate
Range(rangestring).Select
ActiveSheet.Shapes.AddChart2(332, xlLineMarkers).Select
ActiveChart.SetSourceData Source:=Range(rangestring2)
For i = 3 To n
legendString = "$B$" & i
legendString2 = "='12 week trend'!" & legendString
ActiveChart.FullSeriesCollection(i - 2).Name = legendString2
Next i
ActiveChart.FullSeriesCollection(1).XValues = "='12 Week Trend'!$C$2:$O$2"
'Turn on updating
Application.ScreenUpdating = True
End Sub
My main hurdle seems to be the fact that I need the code to be able to accommodate data being added to new columns. For example, in this code: the data range is hardcoded to column "O", but I'd like to build a model which would be able to determine which column the range stops at.
The variable rangestring2 dynamically calculates how many rows of data we possess, but at the moment, can't calculate the same for columns.
This is my first time asking for help in this forum! Thank you for your time guys!
You could use one of the usual "find last column" methods, such as
Dim c As Long
With Sheets("12 week trend")
c = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
and then use that to determine your appropriate range strings such as
Dim HdgString As String
rangestring = Range(Cells(3, "C"), Cells(n, c)).Address
HdgString = Range(Cells(2, "C"), Cells(2, c)).Address
rangestring2 = "'12 week trend'!" & rangestring
'...
ActiveChart.FullSeriesCollection(1).XValues = "='12 Week Trend'!" & HdgString
I know this has been asked lot of times but I'm having a trouble with VBA, I am very new to VBA.
I'm working with a single workbook that has a working worksheet. basically I need to sort the Currency column, currently have 14 currencies, I need loop through it (since currency may add through time depending on the customer) then copy the row with the criteria paste it to another sheet with its cell value.
my code below.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In rng
If CStr(xCell.Value) = "USD" Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = xCell.Value
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
'Sheets.Add After:=Sheets(Sheets.Count)
'Sheets(Sheets.Count).Name = xCell.Value
Application.CutCopyMode = False
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I basically got the codes from my research, add them up and not coming into the way I wanted. I wanted to keep the header and the values with criteria,
i,e currency column "AB" is USD as per example above, but the problem is it'll be a lot of coding because I have to go through all 14 currencies plus if there will be new currency that will be added,
also I know there is a way of not declaring multiple sheets and just having another new worksheet with the cell value name but I'm having a problem getting it done all at once. if there will be a simpler and powerful code. I am greatly thankful.
you may want to try this code, exploiting Autofilter() method of Range object
Option Explicit
Sub SortCurrency()
Dim currRng As Range, dataRng As Range, currCell As Range
With Worksheets("Currencies") '<--| change "Currencies" to your actual worksheet name to filter data in and paste from
Set currRng = .Range("AB1", .Cells(.Rows.Count, "AB").End(xlUp))
Set dataRng = Intersect(.UsedRange, currRng.EntireRow)
With .UsedRange
With .Resize(1, 1).Offset(, .Columns.Count)
With .Resize(currRng.Rows.Count)
.Value = currRng.Value
.RemoveDuplicates Array(1), Header:=xlYes
For Each currCell In .SpecialCells(xlCellTypeConstants)
currRng.AutoFilter field:=1, Criteria1:=currCell.Value
If Application.WorksheetFunction.Subtotal(103, currRng) - 1 > 0 Then
dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateWorksheet(currCell.Value).Range("A1")
End If
Next currCell
.ClearContents
End With
End With
End With
.AutoFilterMode = False
End With
End Sub
Function GetOrCreateWorksheet(shtName As String) As Worksheet
On Error Resume Next
Set GetOrCreateWorksheet = Worksheets(shtName)
If GetOrCreateWorksheet Is Nothing Then
Set GetOrCreateWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count))
GetOrCreateWorksheet.name = shtName
End If
End Function
You're pretty close with what you've got, but there's a few things to note:
On Error Resume Next is normally a bad plan as it can hide a whole lot of sins. I use it in the code below, but only because I immediately deal with any error that might have happened.
xCell.Value.Range("A" & J + 1) makes no sense. Chop out the middle of that line to leave xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
Rather than checking if the value is a specific currency, you should be taking the value, whatever currency it is, and dealing with it appropriately.
Using J as a counter works for one currency, but when dealing with multiple, it'll be easier to just check where it should go on the fly.
All told, the below code should be close to what you're looking for.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim targetSheet As Worksheet
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
Application.ScreenUpdating = False
For Each xCell In rng
Set targetSheet = Nothing
On Error Resume Next
Set targetSheet = Sheets(xCell.Value)
On Error GoTo 0
If targetSheet Is Nothing Then
Sheets.Add After:=Sheets(Sheets.Count)
Set targetSheet = Sheets(Sheets.Count)
targetSheet.Name = xCell.Value
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & J + 1)
Else
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & targetSheet.Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub
OK, there's quite a lot going on here... I'm going to try and tackle one problem at a time.
1 - You could do with testing whether a worksheet already exists rather than creating it every time
Assuming you want to do something for each and every currency in your loop, I would suggest not using the if condition you're using at the moment, "if value = "USD"", and instead use the cell value to determine the name of the sheet, whatever the cell value is.
First of all you need a seperate function to test whether the sheet exists, like
Public Function DoesSheetExist(SheetName as String)
On Error Resume Next
Dim WkSheet as WorkSheet
'sets worksheet to be the sheet NAMED the current currency name
Set WkSheet = Sheets(SheetName)
'because of on error resume next, WkSheet will simply be "Nothing" if no such sheet exists
If WkSheet is Nothing Then
DoesSheetExist = False
Else
DoesSheetExist = True
End If
End Function
You can then call this function in your code, and only create new sheets when you need to
2 - The loop itself
So instead, I would suggest your loop probably wants to look more like this:
Dim xSheet as Worksheet 'declare this outside the loop
For Each xCell In rng
If DoesSheetExist(xCell.Value) Then
set xSheet = Sheets(xCell.Value) 'this is the code for if the sheet does exist - sets the sheet by the sheet name rather than index
Else
set xSheet = Sheets.Add After:=Sheets(Sheets.Count)
xSheet.Name = xCell.Value
End if
With this setup, for every currency your loop will either set xSheet to the currency sheet that already exists, or create that sheet. This assumes that you want to do the same thing to all currencies, if not then extra conditions will need adding in
3 - the copy/paste line itself
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
I don't think this code says what you think it does - what this code actually says is "Copy the Entire Row to the last Sheet's name, and make it equal to the range within xCell's Value at A, (J)+1
I think what you actually wanted to say was this:
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
However, if you're using the code I gave you above you can instead use this now:
xCell.EntireRow.Copy Destination:=xSheet.Range("A" & J + 1)
In fact, you'd be better off doing that, especially if there is a chance that the sheets already existed and were picked up by DoesSheetExist
Personally I would also rather transfer values over than use copy/paste any day, but that's just an efficiency thing, the above should function fine.
I have looked through the other posts about this and have tried adapted the strategies that were recommend by using Set ActiveWorkbook and Set Active Worksheet and I still get the same error. I hope another set of eyes can help out as I am still very new to VBA and I am not all that comfortable with it yet.
Basically the idea is to copy the cells from column f to column j as values as long as the cells of F do not match the cells of J. I get the row count of column E and use that as my count in the for loop.
Code is here:
Private Sub CalculateRewards_Click()
CopyPaste
End Sub
Sub CopyPaste()
Dim n As Integer
Dim i As Integer
n = Sheets("Calculate").Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count
i = n
For Counter = 1 To n
Set curCell = Sheets("Calculate").Range("F2:F" &i)
If "$F" &i <> "$J" &i Then
Sheets("Calculate").Range("$F:$F" &i).Copy
Sheets("Calculate").Range("$J:$J" &i).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
i = i + 1
Next Counter
End Sub
Thanks for the help
Also Edit:
Link to Excel Sheet that has a before page, after first transaction sheet ,and a after second transaction sheet: https://www.dropbox.com/s/n2mn0zyrtoscjin/Rewards.xlsm
CHange this:
Set curCell = Sheets("Calculate").Range("F2:F" &i)
If "$F" &i <> "$J" &i Then
Sheets("Calculate").Range("$F:$F" &i).Copy
Sheets("Calculate").Range("$J:$J" &i).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
To this:
Set curCell = Sheets("Calculate").Range("F2:F" & i)
If curCell <> Sheets("Calculate").Range("$J" & i) Then
Sheets("Calculate").Range("$J:$J" &i).Value = curCell.Value
End If
May need to do some more teaking as I notice you're working with SpecialCells which essentially filters the range, so iterating For i = 1 to n... probably does not work. Maybe something like:
Dim rngCalc as Range
Set rngCalc = Sheets("Calculate").Range("E:E").Cells.SpecialCells(xlCellTypeConstants)
For each curCell in rngCalc.Cells
If curCell <> curCell.Offset(0, 4) Then
curCell.Offset(0, 4).Value = curCell.Value
End If
Next
EDIT: this sub will calculate the points for the last transaction (identified as the furthest-right column containing transactions) and write them down in column C.
Option Explicit
Sub UpdateCurrentPurchase()
Dim CalcSheet As Worksheet
Dim LastTransRange As Range, TargetRange As Range
Dim LastTransCol As Long, LastTransRow As Long
Dim PurchaseArray() As Variant
Dim Points As Long, Index As Long
'set references up-front
Set CalcSheet = ThisWorkbook.Worksheets("Calculate")
With CalcSheet
LastTransCol = .Cells(2, .Columns.Count).End(xlToLeft).Column '<~ find the last column
LastTransRow = .Cells(.Rows.Count, LastTransCol).End(xlUp).Row
Set LastTransRange = .Range(.Cells(2, LastTransCol), .Cells(LastTransRow, LastTransCol))
Set TargetRange = .Range(.Cells(2, 6), .Cells(LastTransRow, 6)) '<~ column F is the Current Purchase Col
LastTransRange.Copy Destination:=TargetRange '<~ copy last transactions to Current Purchase Col
End With
'pull purchases into a variant array
PurchaseArray = TargetRange
'calculate points
For Index = 1 To LastTransRow
Points = Int(PurchaseArray(Index, 1) / 10) '<~ calculate points
CalcSheet.Cells(Index + 1, 3) = Points '<~ write out the points amount in col C
Next Index
End Sub
ORIGINAL RESPONSE: I think the below will get you where you're going. That being said, it seems like simply overwriting column J with column F (as values) might be the fastest way to an acceptable answer, so if that's the case we can re-work this code to be much quicker using Range objects.
Option Explicit
Private Sub CalculateRewards_Click()
CopyPaste
End Sub
Sub CopyPaste()
Dim LastRow As Long, Counter As Long
Dim cSheet As Worksheet '<~ add a worksheet reference to save some typing
'set references up front
Set cSheet = ThisWorkbook.Worksheets("Calculate")
With cSheet
LastRow = .Range("E" & .Rows.Count).End(xlUp).Row '<~ set loop boundary
'loop that compares the value in column 6 (F) to the value in
'column 10 (J) and writes the value from F to J if they are not equal
For Counter = 1 To LastRow
If .Cells(Counter, 6).Value <> .Cells(Counter, 10).Value Then
.Cells(Counter, 10) = .Cells(Counter, 6)
End If
Next Counter
End With
End Sub