I need to select the demand range in sheet 1 corresponding to the part number selected in Sheet 2 of my workbook. So far, I have written the macro to automatically select the part number in sheet 1 when the same part number is selected in sheet no 2. But, I'm having trouble selecting the range corresponding to the part number, which I want to base my calculations on. Can anyone please tell me how to select the range?
Public Sub calculation()
Dim x As Variant
Dim rng As Range
Dim i As Variant
Dim j As Integer
Dim findcell As Range
Dim a_1 As Range
Dim b_1 As Range
Dim rnge As Range
Worksheets("Sheet2").Activate
x = Worksheets("Sheet2").Range("C3").Value
Worksheets("Sheet1").Activate
Set rng = Worksheets("Sheet1").Range("A2:A26")
For Each i In rng
If x = i Then
Set findcell = i
End If
Next i
j = findcell.Select
Set a_1 = ActiveCell.Offset(0, 1)
Set b_1 = ActiveCell.Offset(0, 66)
Worksheets("Sheet2").Range("C9").Value "=AVERAGE(Sheet1!"a_1.Address":"b_1.Address")"
End Sub
Should be able to do something like this:
Public Sub calculation()
Dim f As Range
Set f = Worksheets("Sheet1").Range("A2:A26").Find( _
what:=Worksheets("Sheet2").Range("C3").Value, _
lookat:=xlWhole)
With Worksheets("Sheet2").Range("C9")
If Not f Is Nothing Then
.Formula = "=AVERAGE(Sheet1!" & f.Offset(0, 1).Resize(1, 66).Address & ")"
Else
.Value = "???"
End If
End With
End Sub
Related
Hi guys i need some help on VBA.
I have range of numbers in sheet 1 from cells A6:O29. Next I have specific numbers selected in Sheet 3 in Column "B".
[![enter image description here][1]][1]
[![enter image description here][2]][2]
I want to loop throw each value in Sheet 3 Column B and find that specific value in Sheet 1 range A6:O29
Next it should paste Entire Row from Sheet 1 starting From Column (Q:CF) in Sheet 3 Starting from Column C onwards
I have coded it but its not working.
Private Sub CommandButton1_Click()
Dim main As Worksheet
Dim outcome As Worksheet
'main sheet contains Range to search number in
Set main = ThisWorkbook.Sheets("Sheet1")
'outcome sheet has specific values in Column B
Set outcome = ThisWorkbook.Sheets("Sheet3")
'column B values are considrered as doubles
Dim valuesfind As Double
'range where values are to be found
Dim myrange As Range
Set myrange = Worksheets("Sheet1").Range("A6:O29")
'no of times to loop code based on values in outcomesheet
locations = Worksheets("Sheet3").Cells(Rows.Count, 2).End(xlUp).Row
For i = 6 To locations
degrees = outcome.Range("B" & i).Value
For b = 6 To Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
If main.Range("A6:O29" & b).Value = degrees Then
outecome.Range("C:BR" & i).Value = main.Range("Q:CF" & b).Value
Exit For
End If
Next b
Next i
End Sub
[1]: https://i.stack.imgur.com/uBo66m.png
[2]: https://i.stack.imgur.com/D0bRUm.png
Please remember to declare all variables, add Option Explicit at the top of your module to help you enforce it.
Try the code below:
Option Explicit
Private Sub CommandButton1_Click()
'main sheet contains Range to search number in
Dim main As Worksheet
Set main = ThisWorkbook.Sheets("Sheet1")
Const mainCopyRng As String = "Q?:CF?"
'outcome sheet has specific values in Column B
Dim outcome As Worksheet
Set outcome = ThisWorkbook.Sheets("Sheet3")
Const outcomePasteRng As String = "C?:BR?"
'range where values are to be found
Dim myrange As Range
Set myrange = main.Range("A6:O29")
'no of times to loop code based on values in outcomesheet
Dim outcomeLastRow As Long
outcomeLastRow = outcome.Cells(Rows.Count, 2).End(xlUp).Row
Dim i As Long
For i = 6 To outcomeLastRow
Dim Degrees As Double
Degrees = outcome.Cells(i, 2).Value
Dim searchRng As Range
Set searchRng = myrange.Find(Degrees, LookIn:=xlValues, LookAt:=xlWhole)
If Not searchRng Is Nothing Then
Dim searchRow As Long
searchRow = searchRng.Row
outcome.Range(Replace(outcomePasteRng, "?", i)).Value = main.Range(Replace(mainCopyRng, "?", searchRow)).Value
End If
Next i
End Sub
This should work.
Sub Test()
Dim main As Worksheet
Set main = ThisWorkbook.Sheets("Sheet1")
Dim myrange As Range
Set myrange = main.Range("A6:O29")
Dim outcome As Worksheet
Set outcome = ThisWorkbook.Sheets("Sheet3")
'Set reference to locations in sheet3.
Dim locations As Range
With outcome
Set locations = .Range(.Cells(1, 2), .Cells(Rows.Count, 2).End(xlUp))
End With
'Search for each location in Sheet1 and if found copy to Sheet3.
Dim location As Range
Dim FoundLocation As Range
For Each location In locations
Set FoundLocation = myrange.Find( _
What:=location, _
After:=myrange.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
If Not FoundLocation Is Nothing Then
main.Cells(FoundLocation.Row, 1).Resize(, 15).Copy _
Destination:=location.Offset(, 1)
End If
Next location
End Sub
The following code is the one that I'm trying to work with, but I still can't make it work with merge rows. The main idea is to create a loop to check each row from D1:D150 and if the criteria are met then copy the entire row.
This is how my data looks like
Sub attributes()
'--------------------------------------------------------------------
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range, ws, ws0 As Worksheet
Dim strAsses1 As Boolean
Dim num As Integer
'------------------------------
Set ws = ActiveWorkbook.Sheets("Contract Attributes")
Set ws0 = ActiveWorkbook.Sheets("ReviewerTab")
ws.Activate
Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("A1:A150")
'Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("D1:D150")
'Set aCell2 = ActiveWorkbook.Sheets("Contract Attributes").Range("D:D").Find("Current Modifications", LookIn:=xlValues)
'--------------------------------------------------------------------
strName1 = InputBox("Which contract modification would you like to review?")
num = 5
For Each Cel In aCell1
If InStr(1, Cel, strName1, vbTextCompare) > 0 Or InStr(1, Cel, "x") > 0 Then
Cel.MergeArea.Select
Selection.EntireRow.Copy
ws0.Activate
Rows(num).Insert
ws.Activate
num = num + 1
End If
Next Cel
'--------------------------------------------------------------------
'ws0.Columns(4).Delete
'aCell2.Select
'ActiveCell.EntireRow.Copy
'Sheets("ReviewerTab").Range("A5").Insert
End Sub
TIPS
To begin with, I would recommend that you see How to avoid using Select in Excel VBA. Next you need to identify the range object that you need to copy and then copy them across.
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range You need to declare them explicitly else the first four objects are declared as Variant and not Range. For example Dim Cel As Range, aCell1 As Range, aCell2 As Range, aCell3 As Range, aCellAsses As Range
Do not copy the rows in a loop. It will be slow. Identify the rows you want to copy and then copy them in one go. Below is an example
SAMPLE SCENARIO
To demonstrate how this works, I am taking the below sample.
CODE
I have come up with a basic code. I have commented it so you should not have a problem understanding it. But if you do then feel free to ask :).
Option Explicit
Sub Sample()
Dim wsInput As Worksheet
Dim wsOuput As Worksheet
Dim RangeToCopy As Range
Dim lRow As Long, i As Long, num As Long
Dim searchText As Variant
'~~> Row in output sheet where the rows will be copied
num = 5
'~~> Set your input and output sheets
Set wsInput = ThisWorkbook.Sheets("Contract Attributes")
Set wsOuput = ThisWorkbook.Sheets("ReviewerTab")
'~~> Take the input from the user
searchText = InputBox("Which contract modification would you like to review?")
If Len(Trim(searchText)) = 0 Then Exit Sub
With wsInput
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the cells and check for criteria
For i = 1 To lRow
If InStr(1, .Range("A" & i).Value2, searchText, vbTextCompare) Then
'~~> identify the rows you need to copy and store them
'~~> in a range object
If RangeToCopy Is Nothing Then
Set RangeToCopy = .Range("A" & i).MergeArea.EntireRow
Else
Set RangeToCopy = Union(RangeToCopy, .Range("A" & i).MergeArea.EntireRow)
End If
End If
Next i
End With
'~~> Copy them across. You can insert them as well
If Not RangeToCopy Is Nothing Then
RangeToCopy.Copy wsOuput.Rows(num)
End If
End Sub
IN ACTION
You need to include the merge area before "Select".
After you copy the rows, you need to count how many merged rows in the copy. I add a new variable num2 to do so. The loop cannot just simply num=num+1, it varies from what rows copied.
You may try the below code.
Sub attributes()
'--------------------------------------------------------------------
Dim Cel, aCell1, aCell2, aCell3, aCellAsses As Range, ws, ws0 As Worksheet
Dim strAsses1 As Boolean
Dim num As Integer
Dim num2 As Integer
Set ws = ActiveWorkbook.Sheets("Contract Attributes")
Set ws0 = ActiveWorkbook.Sheets("ReviewerTab")
ws.Activate
Set aCell1 = ActiveWorkbook.Sheets("Contract Attributes").Range("A1:A150")
strName1 = InputBox("Which contract modification would you like to review?")
num = 5
For Each Cel In aCell1
If InStr(1, Cel, strName1, vbTextCompare) > 0 Or InStr(1, Cel, "x") > 0 Then
Range(Cells(Cel.Row, 1), Cells(Cel.Row, Cells(Cel.Row, Columns.Count).End(xlToLeft).Column)).Select
num2 = Selection.Rows.Count
Selection.EntireRow.Copy
ws0.Activate
Rows(num).Insert
ws.Activate
num = num + num2
End If
Next Cel
End Sub
I have a table with 66 columns (representing the Wind turbines) and about 5000 rows of timestamps. I have to check if the value of each cell, in this case velocity, meets a certain criteria, if it does, i extract name of the Wind turbine from the topmost row. Using the name, i need to "lookup" the Wind turbine closest to it from a Matrix in a different sheet and return this.
Option Explicit
Public Sub ErsetzenNachbar()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Arr As Variant
Dim Rng As Range
Dim SheetName As String
Dim i As Long
Dim j As Long
Dim WeaMat As Workbook
Dim Mat As Range
Dim Arr2 As Variant
Dim target As Long
Dim MOfound As String
SheetName = "INPUT_WIND"
'Range in the first Workbook
Set Rng = wb.Worksheets(SheetName).Range("C2:AG5000")
'Open the second Workbook
Set WeaMat = Workbooks.Open("C:\Users\Nikhil.srivatsa\Desktop\WeaMat")
'Set range for second workbook with the Matrix
Set Mat = WeaMat.Worksheets(1).Range("A2:AP68")
'Range into array
Arr = Rng.Value
'loop through array
For i = LBound(Arr, 1) To UBound(Arr, 1)
For j = LBound(Arr, 2) To UBound(Arr, 2)
If Arr(i, j) = 0.047 Then
'wind turbine Name from the topmost row
Arr(LBound(Arr, 1), j) = target
'look for target in the Matrix and fetch the neighboring turbine here is where i need help!
End If
Next j
Next i
End Sub
For example I look for the cells containing 0,047 (may vary) and get "MO30" the turbine name. Now i lookup MO30 in the Matrix of a second workbook and ask it to fetch MO42 from the Matrix since it is the first closest wind turbine.
would using Collections or Dictionary help in this case? or should I create an array out the Matrix? or use the Find function ?
Here is a simple example using two sheets rather than two workbooks, but see if you can adapt it for your set up.
Sub x()
Dim rFind1 As Range, s As String, rFind2 As Range
With Sheet1.Range("A1").CurrentRegion
Set rFind1 = .Find(what:=0.047, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False) 'look for value on sheet1
If Not rFind1 Is Nothing Then
s = .Rows(1).Cells(rFind1.Column) 'if found, find corresponding row 1 value
Set rFind2 = Sheet2.columns(1).Find(what:=s) 'look for this in sheet2
If Not rFind2 Is Nothing Then MsgBox rFind2.Offset(, 1) 'report contents of cell to the right
End If
End With
End Sub
Sheet1
Sheet2
Try this code, please:
Sub findTurb()
Dim sh As Worksheet, sh2 As Worksheet, rng As Range, strTurb As String
Const timeSt As Double = 0.047
Set sh = ActiveSheet 'use here your sheet
Set sh2 = Worksheets("second") 'use here your sheet
Set rng = sh.UsedRange.Find(timeSt)
If Not rng Is Nothing Then
strTurb = sh.Cells(1, rng.Column).value
Set rng = sh2.Range("A1:A" & sh2.Range("A" & Cells.Rows.Count).End(xlUp).Row).Find(strTurb)
If Not rng Is Nothing Then
MsgBox rng.Offset(, 1).value
End If
End If
End Sub
It can be transformed in a function, receiving time stamp as parameter and returning a string...
I got below table that I need to fill with data based on current month (Worksheet "PR"):
An example of the raw data looks like (Worksheet "CSV Data PR"):
I have two issues:
SumIF only works for the first region, all the others take the same data. As example, correct data shows below Feb.
For some reason it pulls the formula down all the way..., whilst it should stop at Western Europe. I am not sure why that is the case.
Based on the following piece of code:
Sub TableDataTest()
Dim rngHdrFound, rngHdrFound2, findrng, USDRng, RegionRNG, rngHeaders, RngHeadersOutPut As Range
Dim x, y As Worksheet
Dim ThisMonth As Date
Dim index As Variant
Application.ScreenUpdating = False
'Set Worksheets
Set x = ThisWorkbook.Sheets("CSV Data PR")
Set y = ThisWorkbook.Sheets("PR")
index = y.Range("D8")
ThisMonth = Format(Date, "MM/YYYY")
'Set HeaderRow
Const ROW_HEADERS As Integer = 1
Set rngHeaders = Intersect(Worksheets("CSV Data PR").UsedRange, Worksheets("CSV Data PR").Rows(ROW_HEADERS))
Set RngHeadersOutPut = y.Range("6:6")
Set rngHdrFound = rngHeaders.Find("In USD")
Set rngHdrFound2 = rngHeaders.Find("Region")
Set findrng = RngHeadersOutPut.Find(What:=ThisMonth, LookIn:=xlFormulas, lookat:=xlWhole)
Set USDRng = Range(rngHdrFound.Offset(1), rngHdrFound.End(xlDown))
Set RegionRNG = Range(rngHdrFound2.Offset(1), rngHdrFound2.End(xlDown))
'Find CurrentMonth + Range
With y
If findrng Is Nothing Then
MsgBox "Error, unable to match " & ThisMonth & " in the specified range", vbCritical
Exit Sub
Else
findrng.Offset(2, 0).Resize(Selection.Rows.Count + 8).Value = Application.WorksheetFunction.SumIf(RegionRNG, "=" & index, USDRng)
End If
End With
Application.ScreenUpdating = True
End Sub
You could try this:
Option Explicit
Sub TableDataTest()
Dim ws As Worksheet, wsData As Worksheet, MonthCol As Integer, ThisMonth As Date, C As Range, _
x As Integer, y As Integer
x = 2 'Number of the column with the region
y = 3 'Number of the column with the data to sum
With ThisWorkbook
Set ws = .Sheets("PR")
Set wsData = .Sheets("CSV Data PR")
End With
ThisMonth = Format(wsData.Range("C2"), "MM/YYYY")
With ws
MonthCol = .Cells.Find(ThisMonth, LookIn:=xlFormulas, lookat:=xlWhole).Column
For Each C In .Range(.Cells(3, Col), .Cells(11, Col))
C = Application.SumIf(wsData.Columns(x), .Cells(C.Row, 1), wsData.Columns(y))
Next C
End With
End Sub
You only need to find the column where the month is on the table, and then hardcode the rows you wanna work in because as for I can see, they are always the same and unlikely to grow.
PS: I'm assuming the table starts on row 3 and column A, otherwise change the starting row 3 on the For Each C range and the criteria inside the sumif taking column 1.
My workbook has two sheets: one "Data" and one "Kiert". I solved to copy rows by specific attributes from "data" to "Kiert" with UserForm, but I added ti user form four textboxes (TextBox1, TextBox2 etc.) and I want to fill the database with constant values added in textbox with one command button in blank colums after pasted data.
I have additional textbox5, which indicates if the copy was succefull ("SIKERES"), this part works fine...
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim lastRow As Long
Dim srcRange As Range, fillRange As Range
Set a = TextBox5
Set d = TextBox1
Set ws = Sheets("Data")
Set Drng = ws.Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy
Sheets("Kiert").Range("A1000000").End(xlUp).Offset(1, 0)
Range("F:F" & lastRow).Formula = TextBox1.Value
If c.Value = ListBox1.Value Then
a.Value = "SIKERES"
End If
End If
Next c
End Sub
I insert here an example:
My main problem is I cannot describe a correct range and description of textboxes, and I don't know where I can put it in my code to run it properly.
I tried this:
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy Sheets("Summary").Range("A1048576").End(xlUp).Offset(1, 0)
Sheets("Kiert").Range("A:A" & lasrRow).Value = TextBox1.Text
If c.Value = ListBox1.Value Then
A.Value = "SIKERES"
End If
End If
Next c
...but its out of range.
It's not very clear what you are trying to do, but the code below will help you paste the values of your textboxes to the relevant column:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim NextFreeRow As Long
Dim srcRange As Range, fillRange As Range
Set Drng = Sheets("Data").Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells 'loop through Column A on Sheet Data
If c = ListBox1.Value Then 'If the cells in Column A Sheet Data matches the selection on your Listbox1 then
NextFreeRow = Sheets("Kiert").Cells(Rows.Count, "A").End(xlUp).Row + 1 'Check the next free row on Sheet Kiert
c.EntireRow.Copy Desination:=Sheets("Kiert").Range("A" & NextFreeRow) 'Paste the entire row from Sheet Data to Sheet Kiert
Range("F" & NextFreeRow).Value = TextBox1.Text 'Copy the contents of TextBox1 to column F
'Add more lines like the one above to copy the values from your Textboxes to the relevant column
TextBox5.Text = "SIKERES"
End If
Next c
End Sub