I have the following code:
Sub LoopThroughDv()
Dim dvCell As Range
Dim inputRange As Range
Dim c As Range
Dim i As Long
Dim h As Range
Dim a As Range
Set h = Worksheets("Ark2").Range("H2")
Set a = Worksheets("Ark2").Range("A2")
'Which cell has data validation
Set dvCell = Worksheets("Ark2").Range("I2")
'Determine where validation comes from
Set inputRange = Evaluate(dvCell.Validation.Formula1)
i = 0
'Begin our loop
Application.ScreenUpdating = True
For Each c In inputRange
dvCell = c.Value
i = i + 1
If h > a Then
Exit For
End If
Next c
Application.ScreenUpdating = True
End Sub
and when h > a i want to change h,a and dvCell to cell H3, A3, and I3 and then continue increasing until blank cell.
Something like the below? The point is you have to loop the entire process until you get the blank cell. You may need to adjust the until portion a bit according to your data setup.
i = 2
Do
Set h = Worksheets("Ark2").Range("H" & i)
Set a = Worksheets("Ark2").Range("A" & i)
'Which cell has data validation
Set dvCell = Worksheets("Ark2").Range("I" & i)
'Determine where validation comes from
Set inputRange = Evaluate(dvCell.Validation.Formula1)
For Each c In inputRange
dvCell = c.Value
If h.Value > a.Value Then Exit For
Next c
i = i + 1
Loop Until h.Offset(1).Value = ""
Related
I have created a macro that checks row 3 in column B for two different criteria and if either are met, it puts the letter "R" in empty cells in the range B5:B20. If all are empty it dumps the word "No" in cell B34. I need this to do the same operation in columncs C to AF but I can't get it to loop. Any help would be appreciated. Thank you.
Sub Column_B()
Dim ws As Worksheet
Dim b As Range
Set ws = Worksheets("January")
For Each b In Range("B5:B20")
If b.Value = 0 And ws.Range("b3") = ws.Range("a34") Or b.Value = 0 And ws.Range("b3") = ws.Range("a35") Then
b.Value = "R"
Else
ws.Range("b34") = "No"
End If
Next b
End Sub
Iterate across the columns B to AF in row 3 and use offsets to loop through the rows 5 to 20.
Option Explicit
Sub Column_BtoAF()
Dim ws As Worksheet, r As Long
Dim cell As Range, c As Range, bEmpty As Boolean
Set ws = Worksheets("January")
For Each c In Range("B3:AF3").Cells
If c.Value2 = ws.Range("A34").Value2 _
Or c.Value2 = ws.Range("A35").Value2 Then
bEmpty = True
For r = 5 To 20
Set cell = c.Offset(r - 3)
If IsEmpty(cell) Then
cell.Value = "R"
Else
bEmpty = False
End If
Next
If bEmpty Then c.Offset(31) = "No" ' row 34
End If
Next
MsgBox "Done"
End Sub
Looking for assistance with the following:
Goal:
Compare cells in 2 defined ranges (same size) one by one. If they are the same then move on to the next set of cells. If not:
Input an integer (between 1 to 2000) in a corresponding cell within a 3rd range (same size as the other 2). Run this in a For loop until the cells in the first 2 ranges equal each other.
Once achieved, then move on to the next set of cells and so forth.
The code I've written up so far is outlined below but its not producing the right results. From what I can tell, the hCell value loops while the rest don't which is putting the If comparison conditions off...
Thank you for any help with this!
Sub Update()
Range("A1").Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Sheets("Funds").Select
Range("A1").Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
'resets the "looping cells" from NR8 to PF207.
'Dim d As Integer
For d = 8 To 207
Range(Cells(d, 382), Cells(d, 422)) = ""
Next
Dim e As Integer
e = 1
Dim fRng As Range: Set fRng = Range("RB8:SP207")
Dim fCell As Range
Dim gRng As Range: Set gRng = Range("SU8:UI207")
Dim gCell As Range
Dim hRng As Range: Set hRng = Range("NR8:PF207")
Dim hCell As Range
Dim i As Integer
i = i
For e = 8 To 207
For Each fCell In fRng.Cells
For Each gCell In gRng.Cells
For Each hCell In hRng.Cells
If Cells(e, 191).Value = 0 Then
Exit For
Else
If (fCell.Value >= gCell.Value Or gCell.Value = "N/A") Then
Exit For
Else
For i = 0 To 2000
If fCell.Value >= gCell.Value Then
Exit For
Else
hCell.Value = i
If fCell.Value >= gCell.Value Then
Exit For
End If
End If
Next i
End If
End If
Next hCell, gCell, fCell
End If
Next e
Range("A1").Select
End Sub
I assume the values in the first two ranges are in some way dependent on the values in the third.
Option Explicit
Sub Update()
Const NCOLS = 41 ' 41
Const NROWS = 200 ' 200
Const LOOPMAX = 2000 ' 2000
Dim wb As Workbook, ws As Worksheet
Dim rng1 As Range, rng2 As Range, rng3 As Range
Dim cell1 As Range, cell2 As Range
Dim i As Long, r As Long, c As Integer, t0 As Double
t0 = Timer
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
Set rng1 = ws.Range("RB8")
Set rng2 = ws.Range("SU8")
Set rng3 = ws.Range("NR8")
'resets NR8 to PF207.
rng3.Resize(NROWS, NCOLS).Value = ""
Application.ScreenUpdating = False
For r = 1 To NROWS
Application.StatusBar = "Row " & r & " of " & NROWS
For c = 1 To NCOLS
Set cell1 = rng1.Offset(r - 1, c - 1)
Set cell2 = rng2.Offset(r - 1, c - 1)
If (cell1.Value <> cell2.Value) Or (cell2.Value = "N/A") Then
i = 0
Do
rng3.Offset(r - 1, c - 1) = i
i = i + 1
Loop Until cell1.Value = cell2.Value Or i > LOOPMAX
End If
Next c
Next r
Application.ScreenUpdating = True
MsgBox "Done", vbInformation, Int(Timer - t0) & " seconds"
rng3.Select
End Sub
I tried this, which returned the rows I want, so a good start. But I really just need the value in Column B, not the entire row. What I really want is to list the value in column B if the value in column C is <>"" and column D <>"". Results in Quote sheet starting in cell C4.
Sub CopyQuoteValues()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Software Options").UsedRange.Rows.Count
B = Worksheets("Quote").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Quote").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Software Options").Range("C17:C" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) <> "" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Quote").Range("A" & B + 1)
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Something like this should do what you need:
Sub CopyQuoteValues()
Dim wsOpt As Worksheet, wsQuote As Worksheet
Dim c As Range, rngDest As Range
Set wsOpt = Worksheets("Software Options")
Set wsQuote = Worksheets("Quote")
Set rngDest = wsQuote.Range("C4")
For Each c In wsOpt.Range("C17", wsOpt.Cells(wsOpt.Rows.Count, "C").End(xlUp)).Cells
If Len(c.Value) > 0 And Len(c.Offset(0, 1)) > 0 Then 'value in C and D ?
c.Offset(0, -1).Copy rngDest 'copy ColB
Set rngDest = rngDest.Offset(1, 0) 'next paste location
End If
Next c
End Sub
I have a range A6:A24 that is blank. I want to paste the value 1 into each cell and copy a resulting calculation in H9 to a new sheet. After that I want to move to the next cell paste "1" but delete the previous "1" and paste the resulting value.
I am either able to paste 1 into every box or just the top.
A6:A24 are years. I am trying to pull the calculation for when each year is equal to 1 (100 percent) meaning all other years need to be equal to zero.
Private Sub CommandButton1_Click()
Dim inputRange1 As Range
Dim inputRange2 As Range
Dim c As Range
Dim i As Long
Dim b As Range
Dim j As Long
Set dvCell2 = Worksheets("Sheet1").Range("A6:A24")
Set inputRange2 = Worksheets("Sheet1").Range("D1")
Set dvCell1 = Worksheets("Sheet2").Range("C1")
Set inputRange1 = Worksheets("Sheet1").Range("B6:B24")
i = 1
j = 1
Application.ScreenUpdating = False
For Each b In inputRange2
dvCell2.Value = b.Value
For Each c In inputRange1
dvCell1.Value = c.Value
Worksheets("Sheet4").Cells(i + 2, j + 3).Value = Worksheets("Sheet3").Range("H9").Value
i = i + 1
Next c
j = j + 1
i = 1
Next b
Application.ScreenUpdating = True
End Sub
Not sure I follow. This will loop through each cell in dvcell2 and put a 1 in it and then copy the value of H9. I'm not sure if you're attempting to do something else.
Private Sub CommandButton1_Click()
Dim inputRange1 As Range
Dim inputRange2 As Range
Dim c As Range
Dim i As Long
Dim b As Range
Dim j As Long
Set dvcell2 = Worksheets("Sheet1").Range("A6:A24")
Set inputRange2 = Worksheets("Sheet1").Range("D1")
Set dvCell1 = Worksheets("Sheet2").Range("C1")
Set inputRange1 = Worksheets("Sheet1").Range("B6:B24")
i = 1
j = 1
Application.ScreenUpdating = False
For Each b In dvcell2
dvcell2.value=0
b.Value = 1
Worksheets("Sheet4").Cells(i + 2, j + 3).Value = Worksheets("Sheet3").Range("H9").Value
j = j + 1
Next b
Application.ScreenUpdating = True
End Sub
I have two worksheets ( sheet 1 and sheet 2) . Sheet 1 has 500X500 table. I want to
- Loop through each row ( each cell )
- Identify the cells which have a value ' X' in it
- Pick the respective column header value and store it in a cell in worksheet 2
For example
AA BB CC DD EE FF GG HH
GHS X
FSJ X
FSA X
MSD
SKD
SFJ X X
SFJ
SFM X
MSF X
Is there a way of writing a macro which will pull values in the form of
GHS -> GG
FSJ->DD
.
.
SFJ->BB HH
I have tried looping algorithms but does not seem to work. Could anyone please help me as I am very new to macros.
Try this .. Assumed that GHS, FSJ ... in column A
Sub ColnItem()
Dim x, y, z As Integer
Dim sItem, sCol As String
Dim r As Range
z = 1
For y = 1 To 500
sItem = Cells(y, 1)
sCol = ""
For x = 2 To 500
If UCase(Cells(y, x)) = "X" Then
If Len(sCol) > 0 Then sCol = sCol & " "
sCol = sCol & ColumnName(x)
End If
Next
If Len(sCol) > 0 Then
Sheets("Sheet2").Cells(z, 1) = sItem & " -> " & sCol
z = z + 1
End If
Next
End Sub
Function ColumnName(ByVal nCol As Single) As String
Dim sC As String
Dim nC, nRest, nDivRes As Integer
sC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
nC = Len(sC)
nRest = nCol Mod nC
nDivRes = (nCol - nRest) / nC
If nDivRes > 0 Then ColumnName = Mid(sC, nDivRes, 1)
ColumnName = ColumnName & Mid(sC, nRest, 1)
End Function
I have placed the values GG, etc., in separate columns of Sheet2, but the code could be modified to put all the information (for a row) in a single cell.
Sub GetColumnHeadings()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng1 As Range, rng2 As Range, rng As Range
Dim off As Integer
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng1 = ws1.Range("A1").CurrentRegion
'CurrentRegion is the Range highlighted when we press Ctrl-A from A1
Set rng2 = ws2.Range("A1")
Application.ScreenUpdating = False
For Each rng In rng1
If rng.Column = 1 Then off = 0
If rng.Value = "X" Then
rng2.Value = rng.EntireRow.Cells(1, 1).Value
off = off + 1
rng2.Offset(0, off).Value = rng.EntireColumn.Cells(1, 1).Value
End If
'if we are looking at the last column of the Sheet1 data, and
'we have put something into the current row of Sheet2, move to
'the next row down (in Sheet2)
If rng.Column = rng1.Column And rng2.Value <> "" Then
Set rng2 = rng2.Offset(1, 0)
End If
Next rng
Application.ScreenUpdating = True
Set rng = Nothing
Set rng2 = Nothing
Set rng1 = Nothing
Set ws2 = Nothing
Set ws1 = Nothing
End Sub
I've also based in on the spreadsheet sample from the original post, where AA appears to be in cell A1.