I am trying to calculate the result of a formula using this code but for some reason i can't figure out why it is not printing in the loop...
Sub findx()
Dim A, B, fct As Variant
Dim k, i As Long
fct = InputBox("What is the function in terms of x?")
A = InputBox("Set lower boundary")
B = InputBox("Set upper boundary")
i = InputBox("How many times would you like to repeat this algorithm?")
Range("A6").Value = A
Range("B6").Value = B
For k = i To k = i + 6
Cells(k, 5).Value = "=" & Replace(LCase(fct), "x", Cells(k, 1).Value)
k = k + 1
Next
End Sub
Related
I have to create a Macro which lets me Concatenate two columns at a time in a given range. For example: In range C1:Z200, I want to concatenate Column C&D, E&F, G&H and so on. How do I do it. This is my current code which only concatenate first two columns..rest remains the same.
Set Range = ActiveSheet.Range("C1:Z100")
For Each c In Range
c.Select
ActiveCell.FormulaR1C1 = ActiveCell & " " & ActiveCell.Offset(0, 1)
ActiveCell.Offset(0, 1).Activate
Selection.Clear
ActiveCell.Offset(0, 2).Activate
Next c
Try this:
Sub Concat()
Dim i As Long, j As Long
For i = 1 To 100 'number of rows
j = 1 'reset column to 1
Do While j < 25 'max number of columns (until Column Y-Z)
j = j + 2 'start from third column (Column C)
Cells(i, j) = Cells(i, j) & " " & Cells(i, j + 1) 'concat
Cells(i, j + 1).ClearContents 'clear
Loop
Next i 'next row
End Sub
Try this:
Sub ConcatAltCellsInAltCols()
Dim oW As Worksheet: Set oW = ThisWorkbook.Worksheets("Sheet11")
Dim iLC As Long: iLC = oW.Cells(1, oW.Columns.Count).End(xlToLeft).Column
Dim iLR As Long: iLR = oW.Cells(oW.Rows.Count, 3).End(xlUp).Row
Dim iC As Long
Dim iR As Long
For iR = 1 To iLR
For iC = 3 To iLC Step 2
oW.Cells(iR, iC).Value = oW.Cells(iR, iC) & oW.Cells(iR, iC + 1)
Next
Next
End Sub
Try this using a one based array for better Performance:
Code
Option Explicit
Sub Conc()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Concat") ' <== change "Concat" to your sheet name to avoid subscript error
Dim v ' variant
Dim lng As Long
Dim j As Integer ' corr.
' use one based array to get field data
v = ws.Range("C1:Z100") ' your OP range
For lng = 1 To UBound(v)
' concatenate columns C&D, E&F, G&H, ...
For j = 0 To 11
v(lng, j * 2 + 1) = v(lng, j * 2 + 1) & v(lng, j * 2 + 2)
Next j
Next lng
' write array values back (overwriting D, F, H,... with the same values)
ws.Range("C1:Z100") = v ' your OP range
End Sub
I need the location of max value (one column) or address, so i can locate two cells left of the max value cell. next is finding the higher value of the two new cells and dividing the higher value with the max value. last step is returning the value to sheet "List1". that s the basic logic :)
thx for any help
the locating of max value and locating cells left of it, that is my main concern.
i cant figure it out. been looking for it but cant get it to work.
Sub DoIt()
'ONE MAIN SHEET (List1)
'MORE SECONDARY SHEETS WHERE DATA FOR MAX VALUE IS
Dim strSheet As String
Dim rng As Range
Dim dblMax As Double
Dim r As Range
i = 4
j = 8
g = 4
h = 20
s = 22
Dim cell As Range
Dim col, row
Do While Cells(i, j).Value <> ""
strSheet = Sheets(1).Cells(i, j)
Sheets(strSheet).Activate
'w = 2
'e = 27
'a = 2
'Do While Cells(a, s).Value >= "0"
'Range("AA1") = "IT WORKS"
'Cells(w, e) = Cells(a, s).Value
'a = a + 1
'w = w + 1
'Loop
Set rng = Sheets(strSheet).Range("V2:V8761")
dblMax = Application.WorksheetFunction.Max(rng)
'CODE FOR MAX VALUE LOCATION
'LOCATING TWO LEFT CELLS OF LOCATION MAX VALUE CELL
'DETERMINING THE HIGHER VALUE
'DIVIDING
Range("Z2") = dblMax 'CONTROL
i = i + 1
Range("Z1") = "IT WORKS" 'CONTROL
Sheets("List1").Activate
Cells(g, h) = "AAA" 'result of higher value cell by max value cell
g = g + 1
Loop
End Sub
thx for help i did it. code is not refind. here is the code:
Sub DoIt()
Dim strSheet As String
Dim rng As Range
Dim dblMax As Double
Dim r As Range
Dim dely As Double
i = 4
j = 8
g = 4
h = 20
l = 21
s = 22
Dim cell As Range
Dim col, row
Do While Cells(i, j).Value <> ""
strSheet = Sheets(1).Cells(i, j)
Sheets(strSheet).Activate 'error on no strsheet
w = 2
e = 27
a = 2
sumall = Application.Sum(Range("v2:v9000"))
'Do While Cells(a, s).Value >= "0"
'Range("AA1") = "nekaj dela"
'Cells(w, e) = Cells(a, s).Value
'a = a + 1
'w = w + 1
'Loop
Set rng = Sheets(strSheet).Range("V2:V9000")
dblMax = Application.WorksheetFunction.Max(rng)
mmm = Application.WorksheetFunction.Match(dblMax, Sheets(strSheet).Range("v:v"), 0)
positionRange = Sheets(strSheet).Range("v:v")
'iii = Application.WorksheetFunction.Index(positionRange, mmm)
'ooo = mmm.Offset(0, -1)
sum1 = Cells(mmm, 12)
sum2 = Cells(mmm, 21)
If sum1 > sum2 Then
'sumall = Application.Sum(Range("l2:l8761"))
PLDP = sumall / 365
dely = sum1 / PLDP * 100
smer = "1"
Else
'sumall = Application.Sum(Range("u2:u8761"))
PLDP = sumall / 365
dely = sum2 / PLDP * 100
smer = "2"
End If
'Range("AA2") = iii
Range("AB2") = sum1
Range("AC2") = sum2
Range("ad2") = dely
Range("ae2") = sumall
Range("af2") = PLDP
Range("Z2") = dblMax 'test cell
i = i + 1
Range("Z1") = "IT WORKS"
Sheets("List1").Activate
Cells(g, h) = smer
Cells(g, l) = dely
g = g + 1
Loop
End Sub
I am trying to write a macro which search data from one sheet and copy's to another.
But now I have a problem because I want to copy data between two searches and paste the whole data from multiple cells into one single cell.
For example in the above picture my macro:
SEARCH for "--------------" and "*****END OF RECORD"
COPIES everything in between , here example data in row 29 and 30 and from column A,B,C
PASTE all the data from multiple cells A29,B29,C29 and then A30,B30,C30 to single cell in sheet 2 say cell E2.
This pattern is reoccurring in the column A so I want to search for the next occurrence and do all the steps 1,2,3 and this time I will paste it in Sheet2 , cell E3.
Below is the code:
I am able to search my pattern but hard time in giving references to the cells in between those searched patterns and then copying all the data to ONE cell.
x = 2: y = 2: Z = 7000: m = 0: n = 0
Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "---------------------" Then m = x
If ThisWorkbook.Sheets("lic").Range("A" & x) = "****** END OF RECORD" Then n = x
If (n > 0) Then
Do
For i = m To n
ThisWorkbook.Sheets("lic").Range("A" & i + 1).Copy
ThisWorkbook.Sheets("lic").Range("B" & i + 1).Copy
ThisWorkbook.Sheets("lic").Range("C" & i + 1).Copy
'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y) = ThisWorkbook.Sheets("lic").Range("A" & m + 1, "C" & n - 1): y = y + 1
'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y).Resize(CopyFrom.Rows.Count).Value = CopyFrom.Value: y = y + 1
Loop While Not x > Z
'Driver's Licence #:Driver's Licence #:Driver's Licence #:
x = 2: y = 2: Z = 7000: counter = 1
Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "Driver's Licence #:" Then counter = counter + 1
If (counter = 2) Then ThisWorkbook.Sheets("Sheet1").Range("B" & y) = ThisWorkbook.Sheets("lic").Range("C" & x): y = y + 1: counter = 0
If x = Z Then Exit Sub
Loop
End Sub
Considering that the search is working correctly, about the copy thing you just need to do:
Sheet2.Range("E2").value = ThisWorkbook.Sheets("lic").Range("A" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("B" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("C" & i + 1).value
The result will be something like: AIR COO; L DAT; A
--------UPDATE---------
It was hard to understand your code, so I'm write a new one. Basically it's copy what it found on sheet1 to sheet2.
Sub Copy()
Dim count As Integer 'Counter of loops to the for
Dim Z As Integer 'Limit of (?)
Dim h As Integer 'Count the filled cells on sheet2
Dim y As Integer 'Counter the columns to be copied
Z = 7000
h = 1
'Assuming that the "----" will always be on the top, the code will start searching on the second row
'if it's not true, will be needed to validate this to.
For count = 2 To Z
If Sheet1.Cells(count, 1).Value <> "****** END OF RECORD" Then
If Sheet1.Cells(count, 1).Value <> "" Then
For y = 1 To 3 'In case you need to copy more columns just adjust this for.
Sheet2.Cells(h, 1).Value = Sheet2.Cells(h, 1).Value & Sheet1.Cells(count, y).Value
Next y
h = h + 1
End If
Else
MsgBox "END OF RECORD REACHED"
Exit Sub
End If
Next count
End Sub
Maybe I don't get the full idea but this might work for you.
I'm not at all sure what you want to see in the final output, so this is an educated guess:
Sub DenseCopyPasteFill ()
Dim wsFrom, wsTo As Worksheet
Dim ur As Range
Dim row, newRow As Integer
Dim dataOn As Boolean
Dim currentVal As String
dataOn = False
newRow = 3
Set wsFrom = Sheets("Sheet1")
Set wsTo = Sheets("Sheet2")
Set ur = wsFrom.UsedRange
For row = 1 To ur.Rows.Count
If wsFrom.Cells(row, 1).Value2 = "--------------" Then
dataOn = True
ElseIf wsFrom.Cells(row, 1).Value2 = "***** END OF RECORD" Then
newRow = newRow + 1
dataOn = False
ElseIf dataOn Then
currentVal = wsTo.Cells(newRow, 5).Value2
wsTo.Cells(newRow, 5).Value2 = currentVal & _
wsFrom.Cells(row, 1) & wsFrom.Cells(row, 2) & _
wsFrom.Cells(row, 3)
End If
Next row
End Sub
If you can get away without using the Windows clipboard, I would. Instead of copy/paste, here I demonstrated how you can simply add or append a value.
Add this sub:
Sub copy_range(rng As Range)
Dim str As String
str = rng.Cells(1).Value & rng.Cells(2).Value & rng.Cells(3).Value
Range("E" & Range("E" & Rows.Count).End(xlUp).Row + 1).Value = str
End Sub
Then your for loop should look like this:
For i = m To n
copy_range ThisWorkbook.Sheets("lic").Range("A" & i + 1 & ":C" & i + 1)
Next i
I am trying to get sum by month value each time if the two strings on two sheets match
Now I don't see anywhere it is going in an infinite loop but still this program is not responding after a while and I have to eventually close excel via; task manager because even Break command wasn't working.
This is a fairly simply program but I don't know how can I make it shorter than this Please advise.
Option Explicit
Sub SumByMon()
Application.ScreenUpdating = False
Dim wk As Worksheet, wt As Worksheet
Dim Astr As String, Bstr As String
Dim i, j, FinalRow, FinalRowG As Long
Dim sm As Double, Jsum As Double, Fsum As Double, Msum As Double, Asum As Double, Masum As Double, Jusum As Double, Julsum As Double, Ausum As Double, Ssum As Double, Osum As Double, Nsum As Double, Dsum As Double
Dim Dt
Dim LMon As Integer
Set wk = Sheets("BR Mailing List_12-4-15 (3)")
Set wt = Sheets("Total By Month")
FinalRowG = wk.Range("N900000").End(xlUp).Row
FinalRow = wt.Range("A900000").End(xlUp).Row
For i = 2 To FinalRow
Jsum = 0
Fsum = 0
Msum = 0
Asum = 0
Masum = 0
Jusum = 0
Julsum = 0
Ausum = 0
Ssum = 0
Osum = 0
Nsum = 0
Dsum = 0
Astr = Trim(wt.Range("A" & i))
For j = 2 To FinalRowG
Bstr = Trim(wk.Range("N" & j))
If Astr = Bstr Then
Dt = wk.Range("T" & j).Value
LMon = Month(Dt)
Select Case LMon
Case 1
sm = wk.Range("S" & j).Value
Jsum = Jsum + sm
Case 2
sm = wk.Range("S" & j).Value
Fsum = Fsum + sm
Case 3
sm = wk.Range("S" & j).Value
Msum = Msum + sm
Case 4
sm = wk.Range("S" & j).Value
Asum = Asum + sm
Case 5
sm = wk.Range("S" & j).Value
Masum = Masum + sm
Case 6
sm = wk.Range("S" & j).Value
Jusum = Jusum + sm
Case 7
sm = wk.Range("S" & j).Value
Julsum = Julsum + sm
Case 8
sm = wk.Range("S" & j).Value
Ausum = Ausum + sm
Case 9
sm = wk.Range("S" & j).Value
Ssum = Ssum + sm
Case 10
sm = wk.Range("S" & j).Value
Osum = Osum + sm
Case 11
sm = wk.Range("S" & j).Value
Nsum = Nsum + sm
Case 12
sm = wk.Range("S" & j).Value
Dsum = Dsum + sm
Case Else
Debug.Print LMon
End Select
Else: End If
Next j
wt.Range("B" & i) = Jsum
wt.Range("C" & i) = Fsum
wt.Range("D" & i) = Msum
wt.Range("E" & i) = Asum
wt.Range("F" & i) = Masum
wt.Range("G" & i) = Jusum
wt.Range("H" & i) = Julsum
wt.Range("I" & i) = Ausum
wt.Range("J" & i) = Ssum
wt.Range("K" & i) = Osum
wt.Range("L" & i) = Nsum
wt.Range("M" & i) = Dsum
Next i
wt.Select
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Thanks for all your effort but even by using array method it is getting in Non-Responding state if you want to have a look at the File Here it is.
There are a number of reasons why this code could have problems:
This line could fail if it's an old or compatibility mode version of Excel : wk.Range("N900000").End(xlUp).Row.
You are writing every cell individually which is very time-consuming. If Sheet3 has a lot of rows in it then your code could appear locked because it's taking so long to write
Your declarations have ceded control of types because all the 'untyped' declarations are Variants. This makes debugging very difficult. In your comment you ask "is it necessary?". Answer: not critical, but it will increase your debugging task by an order of magnitude and the code might work in ways you don't expect. In truth, a practical answer is "yes, it's very necessary".
There are no checks of the cell values and types. If cells are empty or not dates, your code will still run, And if all your variables are Variants, your code will aggregate incorrectly when you run Month(dt).
Using the .Text property can cause problems. If for example the date column is too narrow and you have #### in the cell, then that will be the .Text value (again, out of your control if your variable is an 'undeclared' Variant. Better would be Cstr(cell.Value) or Cstr(cell.Value2).
Your code is very inefficient because it loops through the same data in Sheet1 over and over again. Far better would be to load that just once into a collection whose key is the string value that you are testing. I haven't done that in the sample below as I'm a bit short of time but you should look into doing it. If Sheet1 has a lot of rows then your code really will be slow.
The other point is that it's far quicker to write an array to the Worksheet rather than one cell at a time. In your case, the month aggregations are ideally suited to an array. So you could optimise and shorten your code by using one. The code below deals with the points above and uses an array as an example for you.
You also seem a little unclear about the Debug.Print suggestion made by Noam Hacker. It's a good suggestion so I've given you a couple of examples of it in this code:
Public Sub SumByMonWithArray()
Dim startRowA As Long, startRowB As Long
Dim finalRowA As Long, finalRowB As Long
Dim strA As String, strB As String
Dim m() As Variant
Dim dt As Variant
Dim r As Long, c As Long
Dim i As Long, j As Long
'Define the start and end rows of each sheet
startRowA = 2
startRowB = 2
finalRowA = Sheet3.Cells(Sheet3.Rows.Count, "A").End(xlUp).Row
finalRowB = Sheet1.Cells(Sheet1.Rows.Count, "N").End(xlUp).Row
'Dimension your array
r = finalRowA - startRowA + 1
If r < 1 Then Exit Sub 'exit if there's no data
ReDim m(1 To r, 1 To 12)
For i = startRowA To finalRowA
Debug.Print "In loop i=" & CStr(i) 'shows progress (delete after testing)
strA = Trim(CStr(Sheet3.Cells(i, "A").Value2))
'If test value isn't blank run the comparison
If strA <> "" Then
r = i - startRowA + 1
For j = startRowB To finalRowB
Debug.Print "In subloop i=" & CStr(i) & ", j=" & CStr(j) 'shows progress (delete after testing)
strB = Trim(CStr(Sheet1.Cells(j, "N").Value2))
'If there's a match aggregate the month array
If strB <> "" And strA = strB Then
'Populate a Variant with cell value and check it's a date
dt = Sheet1.Cells(j, "T").Value
If IsDate(dt) Then
c = Month(dt) 'Gets the column index of the array
m(r, c) = m(r, c) + CDbl(Sheet1.Cells(j, "S").Value2)
End If
End If
Next
End If
Next
'Write the aggregate array to Sheet 3
With Sheet3
.Cells(startRowA, "B").Resize(UBound(m, 1), UBound(m, 2)).Value = m
.Activate
.Range("A1").Select
End With
Application.ScreenUpdating = True
End Sub
Consider this mock-up data in Sheet1:
First add a column to the right of column T (Date of Sales?) with formula =MONTH(T2) for cell U2.
Add/Change the Monthly label to Integer (B1:M1 in sample).
Then create dynamic named ranges:
SalesItemCol with formula =OFFSET(Sheet1!$N$1,1,0,COUNTA(Sheet1!$N:$N)-1,1)
SalesQtyCol with formula =OFFSET(Sheet1!$N$1,1,5,COUNTA(Sheet1!$N:$N)-1,1)
SalesMonthCol with formula =OFFSET(Sheet1!$N$1,1,7,COUNTA(Sheet1!$N:$N)-1,1)
Finally on B2, use formula =SUMIFS(SalesQtyCol,SalesItemCol,$A2,SalesMonthCol,B$1) then auto fill the rest.
Alternatively you can create macro to do the above...
I am trying to sum up all of the random integer values over 500 and then present them in a text box, however it is not working and whenever I run the code, it sums to zero. This is inside of a user form using VBA. Any suggestions would be appreciated.
Private Sub CommandButton1_Click()
Dim r As Double, c As Double, rand As Double, y As Double, x As Double, i As Double
r = TextBox1.Value
c = TextBox2.Value
rand = TextBox3.Value
Rnd [5]
i = 0
For x = 1 To r
For y = 1 To c
Cells(x, y).Value = Int(Rnd * rand)
If (ActiveCell.Value >= 500) Then
i = i + ActiveCell.Value
Else ' do nothing
End If
Next y
Next x
Cells(r + 1, c).Value = "SUM"
Cells(r + 1, c + 1).Value = i
MsgBox (i)
End Sub
I don't know much about VBA, but could
Cells(x, y).Value = Int(Rnd * rand)
If (ActiveCell.Value >= 500) Then
.. be referring to different cells?