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
Related
I am very new to VBA. Just started reading it up 2 days ago. I am wondering how could I write a VB codes assigned to a button to read through the whole column and search for similar numbers.
After that identifying similar numbers, it would need to move on to another column to check if the character in the column are same too.
If both of the logic = true . How can i change the cell of the value of another column?
Sample data
For the current example. The code should know that the first column had matching numbers. After that it will check for the name which is "a" in the example. After that it will automatically change the point to 1 and 0. If there are 3 same ones it will be 1,0,0 for the point
You may try recording whatever you want to do with record macros first, then filter out the codes that are not necessary. If you do not know how to record it using macros, click on the link below. You can learn from the recorded macros and slowly improvise your codes in the future from the experience you may gain.
Here's [a link] (http://www.dummies.com/software/microsoft-office/excel/how-to-record-a-macro-in-excel-2016/)
As per image attached in image I am assuming numbers are in Column A, column to check characters is Column J and result needs to be displayed in Column O then try following code.
Sub Demo()
Dim dict1 As Object
Dim ws As Worksheet
Dim cel As Range, fCell As Range
Dim lastRow As Long, temp As Long
Dim c1
Set dict1 = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet2 to your data sheet
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in Column A
c1 = .Range("A2:A" & lastRow)
For i = UBound(c1, 1) To 1 Step -1 'enter unique values with corresponding values in dict1
dict1(c1(i, 1)) = .Range("J" & i + 1) '+1 for Row 2
Next i
Set fCell = .Range("A2")
For Each cel In .Range("A2:A" & lastRow) 'loop through each cell in Column A
temp = WorksheetFunction.CountIf(.Range(fCell, cel.Address), cel) 'get count
If temp > 1 Then
If cel.Offset(0, 9) = dict1(cel.Value) Then
cel.Offset(0, 14).Value = 0
Else
cel.Offset(0, 14).Value = 1
End If
Else
cel.Offset(0, 14).Value = 1
End If
Next cel
End With
End Sub
EDIT
Sub Demo()
Dim ws As Worksheet
Dim lastRow As Long
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.count, "A").End(xlUp).Row 'last row with data in Column A
.Range("O2").Formula = "=IF(MOD(SUMPRODUCT(($A$2:$A2=A2)*($J$2:$J2=J2)),3)=1,1,0)" 'enter formula in Cell O2
.Range("O2").AutoFill Destination:=.Range("O2:O" & lastRow) 'drag formula down
.Range("O2:O" & lastRow).Value = .Range("O2:O" & lastRow).Value 'keep only values
End With
Application.ScreenUpdating = True
End Sub
I have a sheet that contains a week number in column B. I am trying to create a macro which looks for the week number in Cell J2 (or using an inputbox) and then finds the week number in column B selects the data in columns C-G and copies them over to sheet 2 (I can do the copying etc its defining the range i'm struggling with.) Image of datasheet
Here is the code which shows which info I need to copy and paste. I'm struggling to make it find the week number and then define the range. The code below just does week 4.
Sub Copy4()
'
' Copy Macro
' Week number
Sheets("Sheet1").Range("B14:B17").Copy
Sheets("Sheet2").Range("C3").PasteSpecial Paste:=xlPasteValues
Sheets("Sheet2").Range("D3").PasteSpecial Paste:=xlPasteValues
' Data Copy
Sheets("Sheet1").Range("C14:G17").Copy
Sheets("Sheet2").Range("C4").PasteSpecial Paste:=xlPasteValues
Range("B2:G7").Select
Application.CutCopyMode = False
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
End Sub
Thanks in advance for any help
Sub copy()
Dim CopySheet As Worksheet
Dim PasteSheet As Worksheet
Set CopySheet = Worksheets("Sheet2")
Set PasteSheet = Worksheets("Sheet3")
Dim tableMaxCol As Integer
Dim tableMaxRow As Integer
Dim weekNumber As Integer
Dim row As Integer
tableMaxCol = CopySheet.Cells(1, CopySheet.Columns.Count).End(xlToLeft).Column
tableMaxRow = CopySheet.Cells(CopySheet.Rows.Count, 1).End(xlUp).row
weekNumber = CopySheet.Cells(2, 10).Value
For row = 2 To tableMaxRow step 4
If CopySheet.Cells(row, 2).Value = weekNumber Then
CopySheet.Range(CopySheet.Cells(row, 3), CopySheet.Cells(row + 3, 7)).copy _
Destination:=PasteSheet.Range("C4")
End If
Next row
End Sub
Answer edited.
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
I am new to VBA as a language, and I'm having issues sorting a large spreadsheet. The sheet is roughly 400,000 rows by 8 columns. The relevant data begins on row 5. In Column C, I changed the format of the date and rounded it down to give a single integer representing the day.
The goal is to find where the data changes days, and cut and paste all of that day's data to a seperate tab. The code I have written successfully does this for the first 2 days, but the 3rd iteration and beyond will not work properly. I have used a color code (blue) to represent the last row for each day, and I'm using this color change as my loop condition. The 3rd loop ignores the 1st color change and instead cuts and pastes 2 day's worth of data, and the 4th loop moves 3 days.
Would there be a more efficient way to move each day's data to a new tab? Each day represents 28800 rows by 6 columns. It should be noted that an additional macro is run before this in order to simply organize the raw data. The portion of the code giving me issues are the loops following the "Sort the data by date" comment.
Any help would be greatly appreciated! Thanks in advance. Attached is my code and a sample of the data
Sub HOBO_Split_v2()
'Before this code can be run, you must run "Hobo_Organize" 1 time. Press 'Ctrl + Shift + O' to do this
'The purpose of this code is to separate the hobo data by day. Weekends and evenings will be removed.
'This will create smaller data sets, which allows for easier data manipulation
Application.ScreenUpdating = False
'Find the last row
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
'Set the known parameters
Dim days As Range
Set days = Worksheets("Full Data Set").Range("C5:C" & Lastrow)
Dim daychanges As String
daychanges = 0
'Maximum of 3 weeks of data, 21 different sheets
Dim sheetnum(1 To 21) As Integer
For i = 1 To 21
sheetnum(i) = i
Next i
'Loop through the day index (Col C), counting the number of day changes
For Each cell In days
If cell.Value <> cell.Offset(1).Value Then
cell.Interior.ColorIndex = 37
daychanges = daychanges + 1
End If
Next cell
'Add new sheets for each day and rename the sheets
Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "Day 1"
For i = 2 To daychanges
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "Day " & sheetnum(i)
Next i
Sheets("Full Data Set").Select
'Sort the data by date
For Each cell In days
If cell.Interior.ColorIndex = 37 Then
cell.Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Worksheets(Worksheets.Count).Select
ActiveSheet.Range("B2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Move Before:=Sheets("Full Data Set")
Sheets("Full Data Set").Select
Range("C4").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlDown)).Select
Set days = Selection
End If
Next cell
Application.ScreenUpdating = True
End Sub
Example of the data
I'd not pass through any cell coloring and use RemoveDuplicates() method of Range object as like follows:
Option Explicit
Sub HOBO_Split_v2()
Dim datesRng As Range, dataRng As Range, cell As Range
Dim iDay As Long
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Full Data Set")
Set datesRng = .Range("C5", .Cells(.Rows.Count, 3).End(xlUp)) '<--| set dates range
Set dataRng = datesRng.offset(-1).Resize(datesRng.Rows.Count + 1, 6) '<--| set data range as dates one extended to next 5 columns
With datesRng.offset(, .UsedRange.Columns.Count) '<--| use a helper column out of current used range
.value = datesRng.value '<--| copy dates value in helper column
.RemoveDuplicates Columns:=Array(1) '<--| remove duplicates and have only unique values in helper column
For Each cell In .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) '<--| iterate through remaining (unique) day values in helper column
iDay = iDay + 1 '<--| update "current day" counter
dataRng.AutoFilter Field:=1, Criteria1:=Format(cell, "#.00") '<--| filter data by "current day", format the criteria as the actual column C cells format
dataRng.offset(1).Resize(dataRng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=SetWorkSheet(ThisWorkbook, "Day " & iDay).Range("B2") '<--| copy filtered data and paste the into "current day" corresponding sheet
Next cell
.Parent.AutoFilterMode = False '<--| remove autofilter
.Clear '<--| clear helper column
End With
End With
Application.ScreenUpdating = True
End Sub
Function SetWorkSheet(wb As Workbook, SheetName As String) As Worksheet
On Error Resume Next
Set SetWorkSheet = wb.Worksheets(SheetName)
On Error GoTo 0
If SetWorkSheet Is Nothing Then
Set SetWorkSheet = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
SetWorkSheet.Name = SheetName
Else
SetWorkSheet.UsedRange.Clear '<--| clear preceeding values in already existent sheet
End If
End Function
There is no need to iterate over the list twice. GetWorkSheet create the new worksheets for you if they don't exist and handle any errors.
Sub HOBO_Split_v2()
Application.ScreenUpdating = False
Dim cell As Range, days As Range
Dim lFirstRow As Long, Lastrow As Long
Dim SheetName As String
Dim ws As Worksheet
With Sheets("Full Data Set")
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
Set days = .Range("C5:C" & Lastrow)
For Each cell In days
If c.Text <> SheetName Or c.Row = Lastrow Then
If lFirstRow > 0 Then
Set ws = getWorkSheet(SheetName)
.Range("A" & lFirstRow, "A" & cell.Row).EntireRow.Copy ws.Range("A1")
End If
SheetName = c.Text
lFirstRow = i
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function getWorkSheet(SheetName As String) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(SheetName)
If ws Is Nothing Then
Set ws = Worksheets.Add(after:=ActiveSheet)
ws.Name = SheetName
End If
On Error GoTo 0
Set getWorkSheet = ws
End Function
I am copying information from one workbook to another. The code I have so far works great if every column has data. It does not work when I am trying to repeatedly copy information from column A and B of worksheet(supplementary expenses) to worksheet(expenses) and column B is blank. As the next time the sub is run and Column B does have values they are placed in the next blank cell, not the cell that is correlated to column A.
Here is the code I have so far:
Sub SupplementaryExpenses()
Dim x As Workbook
Dim y As Workbook
Set y = Workbooks.Open("File Path")
Set x = Workbooks.Open("File Path")
x.Sheets("b.1 Supplementary expenses").Range("a9", Range("a9").End(xlDown)).Copy
y.Sheets("Expenses").Range("a1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
x.Sheets("b.1 Supplementary expenses").Range("b9", Range("b9").End(xlDown)).Copy
y.Sheets("Expenses").Range("b1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
x.Sheets("b.1 Supplementary expenses").Range("c9", Range("c9").End(xlDown)).Copy
y.Sheets("Expenses").Range("c1").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Also any time this sub is run it would be helpful if there were someway to fill column L with the flag 201601 and then change to 201602 when I bring in the next months data.
Try this:
Sub SupplementaryExpenses()
Dim x As Workbook
Dim y As Workbook
Dim lastrow As Long
Dim tRow as long
Set y = Workbooks.Open("File Path")
Set x = Workbooks.Open("File Path")
With x.Sheets("b.1 Supplementary expenses")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
tRow = y.Sheets("Expenses").Range("a1").End(xlDown).Offset(1, 0).Row
y.Sheets("Expenses").Range("A" & trow).Resize(lastrow - 8, 3).Value = .Range(.Cells(9, 1), .Cells(lastrow, 3)).Value
y.Sheets("Expenses").Range("D" & trow).Resize(lastrow - 8, 1).Value = .Range(.Cells(9, 8), .Cells(lastrow, 8)).Value
End With
End Sub
It will take all of the three columns at once and assign the values to the new area. It will not care about blanks in column B or C.
This should be faster than copy/paste as you only want the values.
Get the last used row and change out your range statements similar to this:
Dim LastRow
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
x.Sheets("b.1 Supplementary expenses").Range(Cells(9, 1), Cells(LastRow, a)).Copy 'this is R1C1 format meaning row then column
You can use this for filling a column
If you put it after the rest of your code and ensure that you have the sheet you want column L populated with active:
sDate = Format(Date, "yyyymm")
For i = 2 To LastRow' you may need to grab this anew if you added lines
If Cells(i, "L") = vbNullString Then 'ensures that there isn't anything in the cell
Cells(i, "L").value = sDate
End If
Next