first time asker here.
I found a nice VBA code to copy the same specific cells from multiple worksheets into a mastersheets and actually does its job (i don't remember where I founf it originally). The only small issue is that it starts to input the data from cell A2, while I would like it to start from cell A4.
Here is the code:
Sub ListFB()
Sheets("Master").Range("A4").Value = "Sheet Name"
For I = 1 To ThisWorkbook.Worksheets.Count
If Sheets(I).Name <> "RiassuntoTEST" Then
Sheets("Master").Cells(I, 1).Value = Sheets(I).Range("B2").Value
Sheets("Master").Cells(I, 2).Value = Sheets(I).Range("C2").Value
Sheets("Master").Cells(I, 3).Value = Sheets(I).Range("C10").Value
Sheets("Master").Cells(I, 4).Value = Sheets(I).Range("C11").Value
Sheets("Master").Cells(I, 5).Value = Sheets(I).Range("C15").Value
Sheets("Master").Cells(I, 6).Value = Sheets(I).Range("C16").Value
Sheets("Master").Cells(I, 7).Value = Sheets(I).Range("C20").Value
Sheets("Master").Cells(I, 8).Value = Sheets(I).Range("C21").Value
Sheets("Master").Cells(I, 9).Value = Sheets(I).Range("C25").Value
Sheets("Master").Cells(I, 10).Value = Sheets(I).Range("C26").Value
Sheets("Master").Cells(I, 11).Value = Sheets(I).Range("C29").Value
Sheets("Master").Cells(I, 12).Value = Sheets(I).Range("C30").Value
Sheets("Master").Cells(I, 13).Value = Sheets(I).Range("C33").Value
Sheets("Master").Cells(I, 14).Value = Sheets(I).Range("C34").Value
End If
Next I
End Sub
What I think it does is take value B2 from Sheet I and copy it to A2 of the mastersheet, then take C2 and copy it to B2, until it has all the required data from that sheet into the same rows, then goes to the next sheet and puts the data in the next rows. As I said above, I would like that this whole process starts from A4 instead of A2.
I am fairly new to this kind of stuff so any input and help is appreciated.
Also, does the row
Sheets("Master").Range("A4").Value = "Sheet Name"
Do anything for my purpose at all?
Thank you!
First issue:
Sheets("RiassuntoTEST").Cells(I, 1).Value
Cells holds what is known as an R1C1 reference. Meaning Row number, Column number. Since this line I = 1 To ThisWorkbook.Worksheets.Count counts from 1 to the number of worksheets you have, this will start pasting in row 1, column 1, also known as cell A1. If you want to up this to cell A4 instead, you will need to increase this by 3 like so:
Sheets("RiassuntoTEST").Cells(I + 3, 1).Value
You will need to do this on every line.
Second issue:
Also, does the row
Sheets("RiassuntoTEST").Range("A4").Value = "Nome Foglio"
Do anything for my purpose at all?
No, it does not, as stated before, your code will (now) start pasting at cell A4, so as soon as the second block starts running, this is overwritten.
I rewrote your code in such a way as to enable you to make all the amendments you might want - perhaps with a little help from the comments I inserted between the lines of code.
Option Explicit
Sub UpdateMaster()
' Variatus #STO 23 Jan 2020
Dim Wb As Workbook
Dim MasterWs As Worksheet
Dim Ws As Worksheet
Dim SourceCell() As String
Dim Rt As Long ' target row
Dim Ct As Long ' target column
Dim i As Integer
Set Wb = ThisWorkbook ' you might specify another workbook
' specify the Master worksheet here
Set MasterWs = Wb.Worksheets("TEST")
' list all the source cells here
SourceCell = Split("B2,C2,C10,C11,C15,C16,C20,C21,C25,C26,C29,C30,C33,C34", ",")
Rt = 4 ' set first row to write to here
With MasterWs
' keep contents in rows 1 to 3 (incl title)
.Range(.Cells(Rt, 1), .Cells(.Rows.Count, "A").End(xlUp) _
.Offset(0, UBound(SourceCell) + 1)) _
.ClearContents
End With
Application.ScreenUpdating = False ' speeds up execution
For i = 1 To Wb.Worksheets.Count
Set Ws = Wb.Worksheets(i)
If Not Ws Is MasterWs Then
For Ct = 0 To UBound(SourceCell)
MasterWs.Cells(Rt + i - 1, Ct + 1) = Ws.Range(Trim(SourceCell(Ct))).Value
Next Ct
End If
Next i
Application.ScreenUpdating = True
End Sub
Related
I would like to prepare a tool which searches for anything in certain column, and if see anything, copy this value and paste this in few elements on its row
For example if in G2 there is value "ADD", then A2+B2 + E2 + F2 would be an "ADD" to (except C)
Its very hard for me to overcome obstacles, so far I came up with that.. I know this code is hard to bear with but I rarely use VBA so i never had a chance to learn so its mix of what I've found here on stackoverflow combined as per my requirements
Dim wb as Workbook
Dim ws As Worksheet
wb = ActiveWorkbook.Name
ws = Application.ActiveSheet
With ws
Set myRange = Range("G1", Range("G1").End(xlDown))
For i = 1 to myRange
if i <>"" Then
Range("A1", Range("A1").End(xlToRight)).Select
Range("A1", Range("A1").End(xlToRight)).Value = i.text
[I know this part will do from the first element of A to the last but I dont know how to choose elements I wish if they're not one next to each other]
Next i
End with
For what you want to do, it seem you don't need to declare "wb" and "ws". Vba default will use the ActiveSheet. Also wb is declared to be workbook, but ActiveWorkbook.Name is acutally an text. Your code will encounter error.
If you want to loop from G1 to its last inputted cell, you can refer to following code:
For i = 1 To Cells(Rows.Count,7).End(xlUp).Row
The rows.count refer to the last row (1048576) in excel. and "end(xlup)" will find the last cell which inputted value at G column. And the ".row" return the row number of the last cell.
Similarly, you can use "Cells(1, Columns.Count).End(xlToLeft)" to find the last column's cell inputted at row 1
You may try below code:
For i = 1 To Cells(Rows.Count, 7).End(xlUp).Row
If Cells(i, 7).Value <> "" Then
Range(Cells(i, 1), Cells(i, 2)).Value = Cells(i, 7).Value
Range(Cells(i, 4), Cells(i, Columns.Count).End(xlToLeft)).Value = Cells(i, 7).Value
End If
Next i
However, You mention you want to copy except C column. Since I dont know what actual condition that you will not copy to the column. I just simply separate the code into 2 parts, one for A and B column, another one for D to the last columns
One option could be the following:
Sub FindAndCopy()
Dim ws As Worksheet, searchRng As Range, cl As Range, searchTerm As Variant
Set ws = ThisWorkbook.ActiveSheet
With ws
Set searchRng = .Range("G1", .Range("G1").End(xlDown))
searchTerm = "ADD"
For Each cl In searchRng
If cl = searchTerm Then
Range("A" & cl.Row) = searchTerm
Range("B" & cl.Row) = searchTerm
Range("E" & cl.Row) = searchTerm
Range("F" & cl.Row) = searchTerm
End If
Next cl
End With
End Sub
I have successfully scripted VBA code for summarizing and formatting a large set of data within a sheet. The script is successful when the macro is run on the next sheet I select. When tasked to apply the script across all sheets in the workbook, the modified script completes the summarizations for each sheet, but only formats the first. We tried to troubleshoot in my data class, but to no avail. This is an image of what it is supposed to look like.
My script for the whole workbook:
Sub tickerdata_all_ws()
'define variables
dim ws as Worksheet
Dim ticker As String
Dim stock_vol As Long
Dim yrclose As Double
Dim yrchange As Double
Dim yrvar As Double
Dim i As Long
Dim sumrow As Integer
Dim lastrow As Long
lastrow = ActiveSheet.UsedRange.Rows.Count
for each ws in Worksheet
'create the column headers
ws.Range("H1").Value = "Ticker"
ws.Range("J1").Value = "Yearly Change"
ws.Range("K1").Value = "Percent Change"
ws.Range("L1").Value = "Total Stock Volume"
'which row our summaries will be placed for above columns
sumrow = 2
'the loop checks each iteration until the last row
For i = 2 To lastrow
'we need to capture the price of the ticker if it is the first of its year
Dim firstprice As Boolean
If firstprice = False Then 'false is the default boolean value, so this statement is true
Dim yropen As Double
yropen = ws.Cells(i, 3).Value
firstprice = True 'we have captured the opening price of the year for the ticker
End If
'now we can check if we are in the same ticker value
If ws.Cells(i + 1, 1).Value <> ws.Cells(i, 1).Value Then
'this should happen when the cell values are finally different / capture all the values
ticker = ws.Cells(i, 1).Value
stock_vol = ws.Cells(i, 7).Value
yrclose = ws.Cells(i, 6).Value
yrchange = yrclose - yropen
If yropen <> 0 Then 'this prevents dividing by zero which will result in overflow error 6
yrvar = (yrclose - yropen) / yrclose
Else
yrvar = 0
yrchange = 0
End If
'insert values into the summary
ws.Cells(sumrow, 9).Value = ticker
ws.Cells(sumrow, 10).Value = yrchange
ws.Cells(sumrow, 11).Value = yrvar
ws.Cells(sumrow, 12).Value = stock_vol
sumrow = sumrow + 1 'sets the stage for the next set of data into row 3
stock_vol = 0 'resets vol for the next ticker
firstprice = False 'allows the next 'first' open price of the loop to be captured
End If
Next i 'finish i iteration of the loop
ws.Range("K:K").NumberFormat = "0.0%" 'aesthetic preference
'format columns colors
Dim colJ As Range
Dim Cell as Range
Set colJ = Range("J2", Range("J2").End(xlDown)) 'from J2 to the last cell entry
For Each Cell In colJ
If Cell.Value > 0 Then
Cell.Interior.ColorIndex = 50
Cell.Font.ColorIndex = 2
ElseIf Cell.Value < 0 Then
Cell.Interior.ColorIndex = 30
Cell.Font.ColorIndex = 2
Else
Cell.Interior.ColorIndex = xlNone 'this really serves no purpose
End If
Next
next ws
End Sub
I am sure there are other, much better ways to accomplish this, but as a novice, this is my code salad, and I'd appreciate any help as to why it is not formatting the other three sheets.
Excel for Mac user, though I've run it via Parallels as well.
Set colJ = Range("J2", Range("J2").End(xlDown)) 'from J2 to the last cell entry
here you get range for active sheet.
Change to:
Set colJ = ws.Range("J2", ws.Range("J2").End(xlDown))
I have a master price worksheet (Test Price) with product name (col A) and price (col B). I want to create a macro that when you click a button it will update the prices through the entire workbook. The previous person in my position already created a MOD that will update prices throughout the WB if it is changed in one WS. I am trying to link the master list to that code. So loop through the list and update one sheet which will use the existing mod to update all other sheets. Can anyone please help with this?
This is the code that updates the sheets, I need to link the master price list to this:
Sub ChangePrice(row As String, price As String)
Dim cropVal As String: cropVal = Cells(row, 2).Value ' inefficient
Dim LastRow As Long
For Each ws In ActiveWorkbook.Worksheets
'simple check for division in A3 (stronger check may be needed)
If ws.Cells(3, 1).Value = "Division:" Then
LastRow = ws.Range("A" & Rows.count).End(xlUp).row
' starts in row 12, though data starts in 13
For i = 12 To LastRow
'check column 2 if crop is the same
If ws.Cells(i, 2).Value = cropVal Then
'if so, change its price in column 10
ws.Cells(i, 10).Value = price
'this handles situations where the symbol is attached
ElseIf ws.Cells(i, 2).Value = cropVal & "®" Then
ws.Cells(i, 10).Value = price
End If
Next i
End If
Next ws
End Sub
You could create a dictionary of the values and then pass the dictionary to the module. You would need to add a For Each loop to your master sheet to find the row with the product for each specific worksheet.
Sub CropValFind()
Dim ProdCol As Range, Cell As Range, PriceCol As Range
Set ProdCol = 'Your product column range here
Set PriceCol = 'Your Price Column range here
For Each Cell in ProdCol
Call ChangePrice(Cell.Value, CreateDictFromColumns("MasterSheetName", ProdCol.Column, PriceCol.Column))
Next
End Sub
Assuming your product and price columns are adjacent to each other and the values are strings:
Pulled from https://stackoverflow.com/a/33523909/10462532
Function CreateDictFromColumns(sheet As String, keyCol As String, valCol As String) As Dictionary
Set CreateDictFromColumns = New Dictionary
Dim rng As Range: Set rng = Sheets(sheet).Range(keyCol & ":" & valCol)
Dim i As Long
Dim lastCol As Long '// for non-adjacent ("A:ZZ")
lastCol = rng.Columns.Count
For i = 1 To rng.Rows.Count
If (rng(i, 1).Value = "") Then Exit Function
CreateDictFromColumns.Add rng(i, 1).Value, rng(i, lastCol).Value
Next
End Function
Then your ChangePrice Sub would look something like this.
Sub ChangePrice(row As String, price As Dictionary)
Dim cropVal As String: cropVal = row
Dim LastRow As Long
For Each ws In ActiveWorkbook.Worksheets
'simple check for division in A3 (stronger check may be needed)
If ws.Cells(3, 1).Value = "Division:" Then
LastRow = ws.Range("A" & Rows.count).End(xlUp).row
' starts in row 12, though data starts in 13
For i = 12 To LastRow
'check column 2 if crop is the same
If ws.Cells(i, 2).Value = cropVal Then
'if so, change its price in column 10
ws.Cells(i, 10).Value = price(row)
'this handles situations where the symbol is attached
ElseIf ws.Cells(i, 2).Value = cropVal & "®" Then
ws.Cells(i, 10).Value = price(row)
End If
Next i
End If
Next ws
End Sub
A great resource to learn the in's and outs of dictionaries can be found here.
I am trying to copy certain column from one worksheet to another but when I apply my code, I get no errors but also no results. I get blank paper. I applied this methodolgy on copying a certain row and it was copied to another worksheet perfectly.
This is regarding the successful attempt to copy row.
The code works just fine:
Sub skdks()
Dim OSheet As Variant
Dim NSheet As Variant
Dim i As Integer
Dim LRow As Integer
Dim NSLRow As Integer
OSheet = "Tabelle3" 'Old Sheet Name
NSheet = "Tabelle5" 'New Sheet Name
LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).row 'Last Row in Old Sheet
Sheets(OSheet).Activate
For i = 2 To LRow
'Finds last row in the New Sheet
If Sheets(NSheet).Cells(2, 1) = "" Then
NSLRow = 1
Else
NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).row
End If
'If cell has "certain # then..."
If Cells(i, 1).Value = Cells(13, 2).Value Then
Cells(i, 1).EntireRow.Copy
Sheets(NSheet).Cells(NSLRow + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next i
End Sub
This little piece of code is the failed attempt to copy column to another worksheet.
Sub trial()
Dim OSheet As Variant
Dim NSheet As Variant
Dim j As Integer
Dim LColumn As Integer
Dim NSLColumn As Integer
OSheet = "Tabelle2" 'Old Sheet Name
NSheet = "Tabelle5" 'New Sheet Name
LColumn = Sheets(OSheet).Cells(1, Columns.Count).End(xlToLeft).Column 'Last Column in Old Sheet
Sheets(OSheet).Activate
For j = 2 To LColumn
'Finds last column in the New Sheet
If Sheets(NSheet).Cells(1, 2) = "" Then
NSLColumn = 1
Else
NSLColumn = Sheets(NSheet).Cells(1, Columns.Count).End(xlToLeft).Column
End If
'If cell has "certain # then..."
If Cells(2, j) = Cells(13, 2) Then
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Cells(2, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Next j
End Sub
....
'If cell has "certain # then..."
If Cells(2, j) = Cells(13, 2) Then
debug.Print Cells(2, j).Address; " = "; Cells(13, 2).Address; " ---- COPY"
debug.print Cells(2, j).EntireColumn.address; Cells(2, j).EntireColumn.cells.count
debug.Print Sheets(NSheet).Cells(2, 2).Address
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Cells(2, 2).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
....
With the line If Cells(2, j) = Cells(13, 2) Then you compare the different cells from row 2 (B2, C2, D2, ...) with the value of cell "B13". If the value is the same you copy this column to the new worksheet.
Is there any equal value in your data? If yes you should get an error message with your code.
You try to copy the values of an entire column to the range starting with "B2". Of cause there is not enough space for this.
=> Either you reduce the source range or you start the destination range on row 1!
To add to the paste destination size, if you really want to paste the entire column, you either need to start at the beginning of the column or choose the entire column. Also, I think you want to make the paste column increase with your NSLColumn
If Cells(2, j) = Cells(13, 2) Then
Cells(2, j).EntireColumn.Copy
Sheets(NSheet).Columns(NSLColumn + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
We have a single formula which we are coping to over to a defined range of over 250'000 cells. The performance of Excel clearly takes a hit. Is there a way to improve the performance by using VBA?
The formula returns either 0 or 1 as a value to the cell depending on 4 criteria. The Excel formula is:
=IF(NOT(ISTEXT($B9)),"",IF((L$5=""),"",IF(AND(M$5>MIN($G9,$H9),L$5<MAX($G9,$H9)),1,0)))
Thanks for your help !
Something like this could be an alternative to 250,000 rows of formulas. As stated in the comments, this still would take some time given the size of the data set. I ran a test with a sheet that just had the necessary cells populated with 249,488 rows and the code took 12 seconds to run. With more data in the sheet I anticipate it taking longer than that.
That said this will reduce the memory of your file significantly since there won't be any formulas:
Sub Run()
Dim i As Long 'Row number for loop
Dim lRow As Long 'Last row of data set
Dim ms As Worksheet
Set ms = Sheets("Sheet1") 'Change to whatever sheet you need this in
With ms
If .Cells(5, 12).Value = "" Then
MsgBox "Please enter a value in Cell L5 before proceeding."
Else
lRow = .Cells(.Rows.Count, 2).End(xlUp).Row 'This is assuming Column B is populated in full to the bottom of the data set
For i = 9 To lRow 'This is assuming you will be starting the calculation in row 9
If IsNumeric(.Cells(i, 2).Value) = False And .Cells(i, 2).Value <> "" Then 'Ensuring Column B is text and not blank
If .Cells(5, 12).Value < WorksheetFunction.Max(.Cells(i, 7).Value, .Cells(i, 8).Value) And .Cells(5, 13).Value > WorksheetFunction.Min(.Cells(i, 7).Value, .Cells(i, 8).Value) Then
.Cells(i, 1).Value = 1 'Assuming you want the 0 or 1 in Column A
Else
.Cells(i, 1).Value = 0 'Assuming you want the 0 or 1 in Column A
End If
End If
Next i
End If
End With
End Sub
EDIT
Per Cornintern's awesome suggestion, I've rewritten this to use arrays instead of looping through the entire range. This now takes less than 2 seconds:
Sub Run()
Dim i As Long 'Row number for loop
Dim lRow As Long 'Last row of data set
Dim ms As Worksheet
Dim mVar1() As Variant
Dim mVar2() As Variant
Dim mVar3() As Variant
Dim rVar() As Variant
Dim num1 As Long
Dim num2 As Long
Set ms = Sheets("Sheet1") 'Change to whatever sheet you need this in
With ms
If .Cells(5, 12).Value = "" Then
MsgBox "Please enter a value in Cell L5 before proceeding."
Else
lRow = .Cells(.Rows.Count, 2).End(xlUp).Row 'This is assuming Column B is populated in full to the bottom of the data set
ReDim rVar(1 To lRow - 8) As Variant
mVar1 = .Range("G9:G" & lRow)
mVar2 = .Range("H9:H" & lRow)
mVar3 = .Range("B9:B" & lRow)
num1 = .Cells(5, 12).Value
num2 = .Cells(5, 13).Value
For i = 1 To UBound(mVar1) 'This is assuming you will be starting the calculation in row 9
If IsNumeric(mVar3(i, 1)) = False And mVar3(i, 1) <> "" Then 'Ensuring Column B is text and not blank
If num1 < WorksheetFunction.Max(mVar1(i, 1), mVar2(i, 1)) And num2 > WorksheetFunction.Min(mVar1(i, 1), mVar2(i, 1)) Then
rVar(i) = 1
Else
rVar(i) = 0
End If
End If
Next i
End If
End With
Range("A9:A" & lRow) = WorksheetFunction.Transpose(rVar)
End Sub
Given that your formula is simple I would expect that the formula approach would calculate faster/better than VBA:
Excel calculates using multiple cores: VBA only uses 1
The overhead of transferring data to VBA and back to Excel is
substantial
Excel can calculate over a million simple formulas per second
Excel can automatically recalculate efficiently if any of the data
changes, but you would have to rerun the entire VBA sub.
I would recommend seeing how long the formula approach takes in practice: I would be surprised if it calculates in more than a second.