This code is working fine but it has minor defect. I was hoping to get some help here.
This code needs to compare 2 values and divide the value in equal parts and place it in next cell.
First 2 conditions are working fine. The third condition is working fine but has 2 issues mentioned below which I need help with.
For example if X = 2 and Y = 8, it should divide Y in 4 equal parts as per X value but it is only placing 3 values of 2 in offset cells
Also, if Y = 7 then it should place values as 2 2 2 1 in corresponding cells
While it is doing the work for first cell having Y > X, it is putting incorrect value in farther cell for next Y > X value
Please advise on what needs to be changed.
Sub Calc()
Dim ws As Worksheet
Dim i, j, x, y As Variant
Dim lrow As Long
lrow = Worksheets("AB").Cells(Rows.Count, 1).End(xlUp).Row
Set ws = Workbooks("BC.xlsm").Worksheets("AB")
j = 9
With ws
.Activate
For i = 2 To lrow
x = Cells(i, 7).Value
y = Cells(i, 8).Value
If y < 0 Then
Cells(i, 8).Offset(0, 1) = y
ElseIf y <= x Then
Cells(i, 8).Offset(0, 1) = y
ElseIf y > x Then
Do Until y <= x
Cells(i, j) = x
y = y - x
j = j + 1
Loop
End If
Next i
End With
End Sub
Your variables i, j, x are not being assigned Data type, only y is being assigned as variant.
If you are planning to use With construct then it should connect to its child objects via a . as demonstrated below.
Your first two conditions have the same action associated so they can be joined by OR.
Sub Calc()
Dim ws As Worksheet
Dim i, j, x, y
Dim lrow As Long
Set ws = Workbooks("BC.xlsm").Worksheets("AB")
lrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
With ws
For i = 2 To lrow
x = .Cells(i, 7).Value
y = .Cells(i, 8).Value
j = 9
If y < 0 Or y <= x Then
.Cells(i, j) = y
ElseIf y > x Then
Do Until y <= x
.Cells(i, j) = x
.Cells(i, j + 1) = y - x
y = y - x
j = j + 1
Loop
End If
Next i
End With
End Sub
I would use a for loop and some if logic inside:
Sub Calc()
Dim ws As Worksheet
Dim i As Long, j As Long, x as double, y as double
Dim lrow As Long
Set ws = Workbooks("BC.xlsm").Worksheets("AB")
j = 9
With ws
lrow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lrow
x = .Cells(i, 7).Value
y = .Cells(i, 8).Value
If y < 0 Then
.Cells(i, j) = y
ElseIf y <= x Then
.Cells(i, j) = y
ElseIf y > x Then
For j = 9 To 8 + Application.RoundUp(y / x, 0)
If y >= x Then
.Cells(i, j) = x
y = y - x
Else
.Cells(i, j) = y
End If
Next j
End If
Next i
End With
End Sub
Recently I was helped with a code that fill down randomnly the cells based on Row#1 values. Answered_Post. (Thanks to #JvdV and #Scott Craner for assist me before.)
What I need to do now is almost the same, but the code will fill the cells leaping the columns as per random value (x) in a total of 10 rows. The repeatable values remain on Row#1.
Below the code provided on that post to fill down rows. I need now, as per picture, fill the columns.
Dim x As Long, y As Long, z As Long
With Sheet1 'Change accordingly
For y = 1 To 15
z = 0
Do While z < 4
x = Int((7 - 2 + 1) * Rnd + 2)
If .Cells(x, y) <> .Cells(1, y) Then
.Cells(x, y) = .Cells(1, y)
z = z + 1
End If
Loop
Next y
End With
Table_With_Sample_Values
Sub FillColumns01()
For y = 1 To 15
z = 0
j = 1
Do While z < 4
x = Int((7 - 2 + 1) * Rnd + 2)
If Cells(x, y) <> Cells(1, y) Then
Cells(y + 1, j) = Cells(1, y)
z = z + 1
j = j + 1
End If
Loop
Next y
End Sub
Sub FillColumns02()
'Using a 3rd Loop
Dim x As Integer, y As Integer, z As Integer, j As Integer
For y = 1 To 10
z = 0
Do While z < 4
For j = 1 To 15
x = Int((7 - 2 + 1) * Rnd + 2)
If Cells(x, y) <> Cells(1, y) Then
Cells(j, x) = Cells(1, y)
z = z + 1
End If
Next j
Loop
Next y
End Sub
I'm trying to create a page index of one worksheet, which has about 1500 rows to trace back the information. My idea is to build up either a function or a code block to realize this function. Unfortunately, both don't work. The code I add to my programm is written by Allen Wyatt (https://excelribbon.tips.net/T011581_Page_Numbers_in_VBA.html). It works if the pagenumber is shown with MsgBox. I want either, it works as a function, with that I get the pagenumber of a random cell (just to enter the cell address of this worksheet) or to integrate it into my loop programm to fill the index with page numbers.
I don't understand why the both methodes don't work. As fuction it only shows invalid value. As the value to loop the chaptern numbers, I only get the page number as 1.
Can any guru explain to me the reason?
Thanks a lot!
1.Function:
Public Function showpagenumber() As Integer
Dim iPages As Integer
Dim iCol As Integer
Dim iCols As Integer
Dim lRows As Long
Dim lRow As Long
Dim x As Long
Dim y As Long
Dim iPage As Integer
iPages = ExecuteExcel4Macro("Get.Document(50)")
With ActiveSheet
y = ActiveCell.Column
iCols = .VPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = iCols _
Or y < .VPageBreaks(x).Location.Column
iCol = x
If y >= .VPageBreaks(x).Location.Column Then
iCol = iCol + 1
End If
y = ActiveCell.Row
lRows = .HPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = lRows _
Or y < .HPageBreaks(x).Location.Row
lRow = x
If y >= .HPageBreaks(x).Location.Row Then
lRow = lRow + 1
End If
If .PageSetup.Order = xlDownThenOver Then
iPage = (iCol - 1) * (lRows + 1) + lRow
Else
iPage = (lRow - 1) * (iCols + 1) + iCol
End If
End With
showpagenumber = iPage
End Function
Code in programm, with that I only get the page number 1.
...
For i = chapterstart To chapterend
emptyrow = WorksheetFunction.CountA(ws2.Range("D:D")) + 1
If Not IsEmpty(ws1.Cells(i, "A")) And IsNumeric(ws1.Cells(i, "A")) Then
iPages = ExecuteExcel4Macro("Get.Document(50)")
With ws1
y = ActiveCell.Column
iCols = .VPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = iCols _
Or y < .VPageBreaks(x).Location.Column
iCol = x
If y >= .VPageBreaks(x).Location.Column Then
iCol = iCol + 1
End If
y = ActiveCell.Row
lRows = .HPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = lRows _
Or y < .HPageBreaks(x).Location.Row
lRow = x
If y >= .HPageBreaks(x).Location.Row Then
lRow = lRow + 1
End If
If .PageSetup.Order = xlDownThenOver Then
iPage = (iCol - 1) * (lRows + 1) + lRow
Else
iPage = (lRow - 1) * (iCols + 1) + iCol
End If
End With
ws2.Cells(emptyrow, "D").Value = iPage
End If
Next
Looking to loop using columns, relatively new to looping and have some existing code which is incredibly cumbersome:
Sub AdvanceWeek2()
Application.ScreenUpdating = False
' Victor
' Week1
Range("V24:V124").Copy
Range("U24").PasteSpecial xlPasteValues
Range("V134:V234").Copy
Range("U134").PasteSpecial xlPasteValues
Range("V244:V334").Copy
Range("U244").PasteSpecial xlPasteValues
' Week2
Range("W24:W124").Copy
Range("V24").PasteSpecial xlPasteValues
Range("W134:W234").Copy
Range("V134").PasteSpecial xlPasteValues
Range("W244:W334").Copy
Range("V244").PasteSpecial xlPasteValues
' Week3
Range("W24:W124").ClearContents
Range("W134:W234").ClearContents
Range("W244:W334").ClearContents
' Nick
' Week1
Range("Z24:Z124").Copy
Range("Y24").PasteSpecial xlPasteValues
Range("Z134:Z234").Copy
Range("Y134").PasteSpecial xlPasteValues
Range("Z244:Z334").Copy
Range("Y244").PasteSpecial xlPasteValues
' Week2
Range("AA24:AA124").Copy
Range("Z24").PasteSpecial xlPasteValues
Range("AA134:AA234").Copy
Range("Z134").PasteSpecial xlPasteValues
Range("AA244:AA334").Copy
Range("Z244").PasteSpecial xlPasteValues
' Week3
Range("AA24:AA124").ClearContents
Range("AA134:AA234").ClearContents
Range("AA244:AA334").ClearContents
This then gets repeated for another 11 people, so you can see how cumbersome this gets. How would I go about automating this into a loop to shorten the code and make it easier to edit in the future if small changes needed to be made?
Try this
Sub AdvanceWeek2()
Application.ScreenUpdating = False
Dim var1 As Long, var2 As Long, cnt As Long
Dim rng As Range
var1 = 22 'for Column V
var2 = 100 'random max number
cnt = 13 'no of people
For i = var1 To var2
Range(Cells(24, i), Cells(124, i)).Copy Cells(24, i - 1)
Range(Cells(134, i), Cells(234, i)).Copy Cells(134, i - 1)
Range(Cells(244, i), Cells(334, i)).Copy Cells(244, i - 1)
If i Mod 2 = 1 Then
Union(Range(Cells(24, i), Cells(124, i)), Range(Cells(134, i), Cells(234, i)), Range(Cells(244, i), Cells(334, i))).ClearContents
i = i + 2
cnt = cnt - 1
If cnt = 0 Then Exit For
End If
Next i
Application.ScreenUpdating = True
End Sub
You'll have to start thinking in column numbers rather than column letters.
Column U is column 21 (U being the 21st letter in the alphabet).
You can reference U24 by either using Range("U24") or Cells(24,21) (row 24, column 21).
You reference a range of cells by giving it the first and last cells in the range, so Range(Cells(24,21),Cells(124,21)) will reference U24:U124 and is the same as writing Range("U24:U124").
Now for the looping bit. You want to reference column 21 for Victor, column 25 for Nick, column 29 for the next person, etc. So you'll increase this loop in steps of 4. You also need to reference different columns in each of these loops - moving column 2 to column 1, column 3 to column 2 and clearing column 3.
This bit of code will show how the loop works by printing the values to the immediate window. It will return 21 0, 21 1, 25 0, 25 1, 29 0, 29 1
Sub Test()
Dim x As Long, y As Long
With ThisWorkbook.Worksheets("Sheet1")
For x = 21 To 29 Step 4
For y = 0 To 1
Debug.Print x; y
Next y
Next x
End With
End Sub
These x and y values need to be used in your column references and seeing as you just want the values we can make one range of cells equal the other rather than copy/pastespecial.
Sub Test()
Dim x As Long, y As Long
With ThisWorkbook.Worksheets("Sheet1")
For x = 21 To 29 Step 4
For y = 0 To 1
.Range(.Cells(24, x + y), .Cells(124, x + y)).Value = .Range(.Cells(24, x + y + 1), .Cells(124, x + y + 1)).Value
.Range(.Cells(134, x + y), .Cells(234, x + y)).Value = .Range(.Cells(134, x + y + 1), .Cells(234, x + y + 1)).Value
.Range(.Cells(244, x + y), .Cells(334, x + y)).Value = .Range(.Cells(244, x + y + 1), .Cells(334, x + y + 1)).Value
Next y
.Range(.Cells(24, x + y), .Cells(124, x + y)).ClearContents
.Range(.Cells(134, x + y), .Cells(234, x + y)).ClearContents
.Range(.Cells(244, x + y), .Cells(334, x + y)).ClearContents
Next x
End With
End Sub
Add a watch for the values of X & Y and step through the code using F8. You'll see the values increase to reference the correct columns.
Note I've used the With..End With keywords. This means that each range that starts with a . is referencing Sheet1 of the workbook containing the code (ThisWorkbook).
Edit:
If you want to copy the cells (including formatting, formula, etc) then you can use:
Sub Test()
Dim x As Long, y As Long
With ThisWorkbook.Worksheets("Sheet1")
For x = 21 To 29 Step 4
For y = 0 To 1
.Range(.Cells(24, x + y + 1), .Cells(124, x + y + 1)).Copy Destination:=.Range(.Cells(24, x + y), .Cells(124, x + y))
.Range(.Cells(134, x + y + 1), .Cells(234, x + y + 1)).Copy Destination:=.Range(.Cells(134, x + y), .Cells(234, x + y))
.Range(.Cells(244, x + y + 1), .Cells(334, x + y + 1)).Copy Destination:=.Range(.Cells(244, x + y), .Cells(334, x + y))
Next y
Union(.Range(.Cells(24, x + y), .Cells(124, x + y)), _
.Range(.Cells(134, x + y), .Cells(234, x + y)), _
.Range(.Cells(244, x + y), .Cells(334, x + y))).ClearContents
Next x
End With
End Sub
(that union line could be used in the first example as well).
From your code it doesn't look like the username is important, just the fact there are 12 users.
12 users, 3 weeks...
A quick and minimal code approach is to:
Loop through your code 12 times (once for each user).
Have a nested loop for the 3 weeks per user, applying an offset to a base (or starting) column for each copy and paste operation.
Sub AdvanceWeek2()
Application.ScreenUpdating = False
Dim intLoopUser As Integer
Dim intLoopWeek As Integer
Dim rngBase As Range
Set rngBase = ActiveSheet.Range("V24:V124")
For intLoopUser = 0 To 35 Step 3 '12 Users, change the Step as required, looked like 3 from your code, maybe 4
For intLoopWeek = 0 To 2 '3 weeks
Select Case intLoopWeek
Case 0 'Week 1
rngBase.Offset(0, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(0, intLoopUser + intLoopWeek).Value
rngBase.Offset(110, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(110, intLoopUser + intLoopWeek).Value
rngBase.Offset(210, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(210, intLoopUser + intLoopWeek).Value
Case 1 'Week 2
rngBase.Offset(0, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(0, intLoopUser + intLoopWeek).Value
rngBase.Offset(110, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(110, intLoopUser + intLoopWeek).Value
rngBase.Offset(210, (intLoopUser + intLoopWeek) - 1).Value = rngBase.Offset(210, intLoopUser + intLoopWeek).Value
Case 2 'Week 3
rngBase.Offset(0, (intLoopUser + intLoopWeek) - 1).ClearContents
rngBase.Offset(110, (intLoopUser + intLoopWeek) - 1).ClearContents
rngBase.Offset(210, (intLoopUser + intLoopWeek) - 1).ClearContents
End Select
Next intLoopWeek
Next intLoopUser
Application.ScreenUpdating = True
End Sub
Trying to solve an equation using excel-vba,
Equation:
xy = 5(x+y)
I use the below vba code to determine the values of x and y and print it in cell A1
Sub equation()
Dim x As Long, y As Long
For x = 1 To 9
For y = 1 To 9
If ((x * y) = (5 * (x + y))) Then
Range("A1") = x & "," & y
End If
Next y
Next x
End Sub
However this code is not working. I guess I am missing something in the IF condition.
I tried the below and this works perfectly,
Sub equation()
Dim x As Long, y As Long
For x = 1 To 9
For y = 1 To 9
If 5 * (x + y) = 45 Then
Range("A1") = x & "," & y
End If
Next y
Next x
End Sub
I even tried with 2 temp variables, but doesn't works,
Sub equation()
Dim x As Long, y As Long, temp1 As Long, temp2 As Long
For x = 1 To 9
For y = 1 To 9
temp1 = x * y
temp2 = 5 * (x + y)
If temp1 = temp2 Then
Range("A1") = x & "," & y
End If
Next y
Next x
End Sub
Can someone tell me what I am doing wrong with the IF condition.
Consider:
xy = 5(x+y)
xy = 5x+5y
xy-5y = 5x
y(x-5) = 5x
y = 5x/(x-5)
Then just plug in values for x and solve for y
Sub qwerty()
Dim x As Long, y As Long
For x = 6 To 13
y = 5 * x / (x - 5)
Cells(x, 1) = x
Cells(x, 2) = y
Next x
End Sub
Pick any values for x, just avoid x = 5.Declare y as Double if you require the fractional part: