Source code:
Dim TH As Double
Lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
'starting point
sRow = 2
'Loop in all cells
For i = sRow To Lr
'check if cell value are not same
If Cells(i, 1).Value <> Cells(i + 1, 1) Then
'if not same then merge all the above cells
Range("I" & sRow, "I" & i).Resize(, 7).Select
TH = Application.WorksheetFunction.Sum(Selection)
**If TH <> 40 Then**
Range("A" & sRow, "A" & i).Interior.Color = RGB(255, 0, 0)
End If
In this Code:
If TH <> 40 Then condition not working when ever the TH is Calculated on Decimal Numbers.
Such as 3.60,0.80,4.60 Sum is coming as 40 when use SUM Function but If Condition is not getting fulfilled.
Please Help
I have tried this, putting decimals all over and it works:
Sub TestMe()
Dim lr As Long
Dim TH As Double
Dim i As Long
lr = 10
For i = 1 To lr
If Cells(i, 1).Value <> Cells(i + 1, 1) Then
Range("I" & 6, "I" & i).Resize(, 7).Select
TH = Application.WorksheetFunction.Sum(Selection)
If TH <> 40 Then
Range("A" & 6, "A" & i).Interior.Color = RGB(255, 0, 0)
End If
End If
Next
End Sub
Thus, probably the problem is the way you put the decimals. In some systems (German or French), the decimal separator is ,, while in English systems it is a point - .. Thus, you might be using the wrong one.
Related
I would like to ask how to SUM the values quickly, when they are separated 30 rows from each other?
I would like to sum 9 values and input the result in different column as per the code below:
Sub sum()
Range("EG12").Formula = "=Sum(C12,C282, C552, C822,C1092,C1362,C1632,C1902,C2172,C2442)"
Range("EG42").Formula = "=Sum(C42,C312,C582, C852,C1122,C1392,C1662,C1932,C2202,C2472)"
Range("EG72").Formula = "=Sum(C72,C342,C612, C882,C1152,C1422,C1692,C1962,C2232,C2502)"
Range("EG102").Formula = "=Sum(C102,C372,C642,C912,C1182,C1452,C1722,C1992,C2262,C2532)"
End Sub
Where as you may have notice every destination cell is located exactly 30 rows between each other (inner rows are empty or contains different values) likewise copied cells, that are located exactly 270 rows between each other (see the image attached).
I was trying to do formula like this:
Sub sum2()
Dim lastrow As Long, i As Integer, total As Double, finalsum As Double
lastrow = Range("C2442").End(xlUp).Row
For i = 30 To lastrow
total = total + WorksheetFunction.sum(Range("C12" & i & "EG12" & i))
Next
finalsum = total
End Sub
...but I've got "Method 2Range of object2_Global failed.
Does somebody have some idea about this?
Thanks & regards,
I didn t make it that pretty with the 170 sum but you should understand the point like this:
Sub test2()
Dim lastrow As Long, i As Long, finalsum As Long
lastrow = Range("C2442").End(xlUp).Row
finalsum = 0
For i = 12 To lastrow Step 30
Range("E" & i).Value = WorksheetFunction.Sum(Cells(i, 3).Value, Cells(i + 170, 3).Value, Cells(i + 2 * 170, 3).Value, Cells(i + 3 * 170, 3).Value, Cells(i + 4 * 170, 3).Value, Cells(i + 5 * 170, 3).Value, Cells(i + 6 * 170, 3).Value, Cells(i + 7 * 170, 3).Value, Cells(i + 8 * 170, 3).Value, Cells(i + 9 * 170, 3).Value)
finalsum = finalsum + Range("E" & i).Value
Next i
End Sub
Try it with loops and unions.
Option Explicit
Sub sum30by270()
Dim i As Long, j As Long, lr as long
Dim r1 As Range, r2 As Range
With Worksheets("sheet2")
lr = .cells(.rows.count, "C").end(xlup).row
Set r1 = .Cells(12, "C")
For i = 282 To lr Step 270
Set r1 = Union(r1, .Cells(i, "C"))
Next i
'Debug.Print r1.Address(0, 0)
Set r2 = .Cells(12, "EG")
For j = 42 To 102 Step 30
Set r2 = Union(r2, .Cells(j, "EG"))
Next j
'Debug.Print r2.Address(0, 0)
r2.Formula = "=sum(" & r1.Address(0, 0) & ")"
End With
End Sub
Few remarks:
lastrow = Range("C2442").End(xlUp).Row
is not the right usage, you might want to change it to:
'going from specified cell down until empty cell is met
lastrow = Range("C2442").End(xlDown).Row
or
'going from last cell in C column up, until first non-empty cell is met
lastrow = Range(Rows.Count, 3).End(xlUp).Row
Second issue, if you want to loop every 30 rows, you should do it like this (also remember about proper indentation of your code!):
For i = 12 To lastrow Step 30
total = total + WorksheetFunction.Sum(Range(Cells(i, 1), Cells(i, 5)))
Next
finalsum = total
"C12" & i & "EG12" & i - & operator is a string concatenation, not addition, this is why you might get unexpected result.
Well, thank you all guys for our contribution. I would like to add final working formula for this issue:
Sub sum_1to10()
Dim i As Long, j As Long, lr As Long
Dim r1 As Range, r2 As Range
With Worksheets("13")
lr = .Cells(.rows.Count, "C").End(xlUp).Row
Set r1 = .Cells(12, "C") 'First cell with data in my worksheet - [![enter image description here][1]][1] C12
For i = 12 To 2442 Step 270 ' From 1st cell with data to 10th cell in this order C2442
'When put "lr" instead 2442 the values will be calculated as per all worksheet data included (in my case it was down to 8377
Set r1 = Union(r1, .Cells(i, "C"))
Next i
Set r2 = .Cells(12, "Eh")
For j = 12 To 1086 Step 30 'First subsequent cell with data with 30 rows step e.g C42, C72, etc
' Value 1086 correspond to the last row in label with sum
Set r2 = Union(r2, .Cells(j, "EG"))
Next j
r2.Formula = "=sum(" & r1.Address(0, 0) & ")"
End With
End Sub
Hopefully I have understood it well.
I decided to modify this formula in order to divide my calculation on 3 separate parts. I am making these bulk calculation for every month, and I have divided it for 3 decades.
I have done the following 2 VBA code in excel. Main purpose is to combine multiple address rows into a single line. Problem is it takes forever to run. Is there anyway I can optimise it?
The data is as such, there is a case# for each of the customer address. The customer address can be split into multiple rows. Example: "Address row 1 - Block 56", "Address row 2 - Parry Avenue", "address row 3 - Postal code". There is a blank space between each new address.
My purpose is to combine the address into a single line, and remove the empty rows in between the case numbers eg "Block 56 Parry Avenue Postal code". There are approx 26K case numbers.
Sub test()
Dim l As Long
Dim lEnd As Long
Dim wks As Worksheet
Dim temp As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wks = Sheets("data")
wks.Activate
lEnd = ActiveSheet.UsedRange.Rows.Count
For l = 3 To lEnd
If Not IsEmpty(Cells(l, 1)) Then
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
Else: Cells(l, 1).EntireRow.Delete
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
End If
Next l
End Sub
and the 2nd code I tried
Sub transformdata()
'
Dim temp As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("A3").Select
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
Do Until IsEmpty(ActiveCell.Offset(1, 3))
temp = ActiveCell.Offset(, 3).Value & " " & ActiveCell.Offset(1, 3).Value
ActiveCell.Offset(, 3).Value = temp
ActiveCell.Offset(1, 3).EntireRow.Delete
Loop
ActiveCell.Offset(1, 0).EntireRow.Delete
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Change the line lEnd = ActiveSheet.UsedRange.Rows.Count. Incorrect way of finding last row. You may want to see This
To delete rows where Cells(l, 1) is empty, use Autofilter. See This
Do not delete rows in a straight loop. Use a reverse loop. Or what you could do is identify the cells that you want to delete in a loop and then delete them in one go after the loop. You may want to see This
Here is a basic example.
Let's say your worksheet looks like this
If you run this code
Sub test()
Dim wks As Worksheet
Dim lRow As Long, i As Long
Dim temp As String
Application.ScreenUpdating = False
Set wks = Sheets("data")
With wks
'~~> Find Last Row
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
For i = lRow To 2 Step -1
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
If temp = "" Then
temp = .Range("C" & i).Value
Else
temp = .Range("C" & i).Value & "," & temp
End If
Else
.Range("D" & i + 1).Value = temp
temp = ""
End If
Next i
End With
End Sub
You will get this output
Now simply run the autofilter to delete the rows where Col D is empty :) I have already give you the link above for the same.
The code below will copy all the data into an array, consolidate it, and add it to a new worksheet. You'll need to make COLUMNCOUNT = the number of columns that contain data.
Sub TransformData2()
Const COLUMNCOUNT = 4
Dim SourceData, NewData
Dim count As Long, x1 As Long, x2 As Long, y As Long
SourceData = Range("A" & Range("D" & Rows.count).End(xlUp).Row, Cells(3, COLUMNCOUNT))
For x1 = 1 To UBound(SourceData, 1)
count = count + 1
If count = 1 Then
ReDim NewData(1 To 4, 1 To count)
Else
ReDim Preserve NewData(1 To 4, 1 To count)
End If
For y = 1 To UBound(SourceData, 2)
NewData(y, count) = SourceData(x1, y)
Next
x2 = x1 + 1
Do
NewData(4, count) = NewData(4, count) & " " & SourceData(x2, 4)
x2 = x2 + 1
If x2 > UBound(SourceData, 1) Then Exit Do
Loop Until IsEmpty(SourceData(x2, 4))
x1 = x2
Next
ThisWorkbook.Worksheets.Add
Range("A1").Resize(UBound(NewData, 2), UBound(NewData, 1)).Value = WorksheetFunction.Transpose(NewData)
End Sub
I am doing automation on matching Data form row Data1 to Data 2,
I was done by looping statement but the problem is take much time, when number of row increase
For that reason i planed do by vlookup, In vlookup only return first occurrence cell but i need to find all match cell and highlighted matched row ,which i show in figure.
Working with cells directly reduces the code performance. Try to set Data1 and Data2 to arrays and work with arrays.
Something like this:
With ActiveSheet
arr = .Range(.[A2], .Cells(.Rows.Count, "A").End(xlUp)).Value
arr2 = .Range(.[D2], .Cells(.Rows.Count, "D").End(xlUp)).Value
For i& = 1 To UBound(arr)
For j& = 1 To UBound(arr2)
If arr(i, 1) = arr2(j) Then
...
End If
Next j
Next i
End With
Hope you are looking for this
Sub testvlookup()
Dim lastrow, lastrowdata, incre, i, j As Long
lastrow = Range("A" & Rows.Count).End(xlUp).Row
lastrowdata = Range("D" & Rows.Count).End(xlUp).Row
incre = 6
For i = 2 To lastrow
For j = 2 To lastrowdata
If Range("A" & i).Value = Range("D" & j).Value Then
Range("D" & j, "G" & j).Interior.ColorIndex = incre
End If
Next j
incre = incre + 1
Next i
End Sub
I don't see the point why it should be to slow for many rows, it would be good to have more informations about that.
I would do it like the others, takes ~1 sec with 100000 comparisons.
Dim i As Integer
Dim b As Integer
i = 1
While i < 20000
Range("A1:A5").Copy Range(Cells(i, 4), Cells(i + 5, 4))
i = i + 5
Wend
MsgBox ("hi")
i = 1
While i < 7
b = 3
While b < 20000
If Cells(i, 1).Value = Cells(b, 4).Value Then
Cells(b, 4).Interior.ColorIndex = i
End If
b = b + 1
Wend
i = i + 1
Wend
End Sub
I am looking for the best way to clean up the cell contents of one particular cell in my spreadsheet. As it exists now, Column D lists a City, State, and High School in the same cell (Screenshot #1). I need to split these values out into 3 unique columns/cells as shown in Screenshot #2. How would I accomplish this?
** Note - The example below is just a sample size. I have thousands of cells to perform this on.
Existing cell format:
New Format (Hopefully):
Use Text-to-Columns "delimited" to split on the comma, then use it again "fixed width" to split the state from the school name (assuming the state is always 2 characters). Clean up spaces with TRIM if required.
Hi something like this should look through all your cells in row D and return the values you are looking for in the next 3 columns; might need a little adjusting
For each cell in Range("D2:D & Range("D2".End(xlDown).Row))
cell.offset(columnOffset:=1) = left(cell,instr(String1:=cell, String2:= ","))
cell.offset(columnOffset:=2) = Mid(cell,instr(String1:=cell, String2:= ",")+1,2)
cell.offset(columnOffset:=3) = right(cell,len(cell)-instr(String1:=cell, String2:= ",")+3)
Next
I tried Jake Duddy's code it contains quite some errors, I do not know if it works. At the same time you can try below code.
Dim LastRow As Long
Dim State_L As String
Dim City_L As String
Dim HS_L As String
LastRow = Range("D" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
City_L = Left(Range("D" & i), InStr(1, Range("D" & i), ",") - 1) ' Getting up to comma
State_L = Mid(Range("D" & i), InStr(1, Range("D" & i), ",") + 1, 2) 'Getting after comma for 2 characters
HS_L = Mid(Range("D" & i), InStr(1, Range("D" & i), ",") + 3, Len(Range("D" & i)) - InStr(1, Range("D" & i), ",")) 'Getting after comma+2 characters upto the end
Range("E" & i).Value = City_L
Range("F" & i).Value = State_L
Range("G" & i).Value = HS_L
Next
Select the cells you wish to process and run this small macro:
Sub ParseData()
Dim r As Range, L As Long, L1 As Long, L2 As Long
For Each r In Selection
t = r.Text
L = Len(t)
L1 = InStr(1, t, ",")
For i = 1 To L
If r.Characters(i, 1).Font.Italic = True Then
L2 = i
Exit For
End If
Next i
r.Offset(0, 1).Value = Mid(t, 1, L1 - 1)
r.Offset(0, 2).Value = Mid(t, L1 + 1, L2 - L1 - 1)
r.Offset(0, 3) = Mid(t, L2)
r.Offset(0, 3).Font.Italic = True
Next r
End Sub
For example:
I want to insert a calculation on a cell using VBA. Here is how i insert it right now. it's work pretty Good but i cannot mod the percent on the invoice sheet. I want that after i insert the row i can modify the percent and it will update automatically the selling price.
Private Sub CommandButton1_Click()
Dim wsInvoice As Worksheet, wsRange As Worksheet, wsPrice As Worksheet
Dim nr As Integer, lr As Integer
With ThisWorkbook
Set wsInvoice = .Worksheets("Invoice")
Set wsRange = .Worksheets("Range")
Set wsPrice = .Worksheets("Price")
End With
nr = wsInvoice.Cells(Rows.Count, 1).End(xlUp).Row + 1
Select Case Me.ComboBox1
Case "Paper"
wsRange.Range("Paper").Copy wsInvoice.Cells(nr, 1)
lr = wsInvoice.Cells(Rows.Count, 1).End(xlUp).Row
For i = nr To lr
wsInvoice.Cells(i, 2) = Application.VLookup(Cells(i, 1), wsPrice.Range("A:B"), 2, 0)
wsInvoice.Cells(i, 3) = (".3")
wsInvoice.Cells(i, 4).Formula = FormatCurrency(wsInvoice.Cells(i, 2).Value / (1 - (wsInvoice.Cells(i, 3))), 2, vbFalse, vbFalse, vbTrue)
Next i
Here is a link to download my document.
https://drive.google.com/file/d/0By_oZy042nKWdTVmX0Fid3JVSHM/edit?usp=sharing
I think the FormatCurrency here is a bit useless, this can be accomplished by formatting the column once and leaving it like that. There seems to be an issue with the Formula and FormulaLocal inside form functions. Here's my fix :
Remove the lines wsInvoice.Cells(i,4).Formula ...
At the end of the CommandButton1_Click(), add this line FormulaCorrection
Inside a module, write down this very simple function that shall do what you want :
Sub FormulaCorrection()
Sheets("Invoice").Activate
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lastRow
Cells(x, 4).FormulaLocal = "=B" & x & "/(1-C" & x & ")"
Next x
End Sub
If I understand you correctly, here is one way:
Modify this line:
wsInvoice.Cells(i, 4).Formula = FormatCurrency(wsInvoice.Cells(i, 2).Value / (1 - (wsInvoice.Cells(i, 3))), 2, vbFalse, vbFalse, vbTrue)
to be:
wsInvoice.Cells(i, 4).Formula = "=" & wsInvoice.Cells(i, 2).Value & "/ (1 - (C" & i & "))"
That seemed to work on my test sheet at least.
Edit:
Also, your whole method can be condensed a bit. This should do the same thing:
Private Sub CommandButton1_Click()
Dim wsInvoice As Worksheet, wsRange As Worksheet, wsPrice As Worksheet
Dim nr As Integer, lr As Integer
With ThisWorkbook
Set wsInvoice = .Worksheets("Invoice")
Set wsRange = .Worksheets("Range")
Set wsPrice = .Worksheets("Price")
End With
nr = wsInvoice.Cells(Rows.Count, 1).End(xlUp).Row + 1
Select Case Me.ComboBox1
Case "Paper"
wsRange.Range("Paper").Copy wsInvoice.Cells(nr, 1)
Case "Pen"
wsRange.Range("B2:B100").Copy wsInvoice.Cells(nr, 1)
Case "Sticker"
wsRange.Range("C2:c100").Copy wsInvoice.Cells(nr, 1)
End Select
lr = wsInvoice.Cells(Rows.Count, 1).End(xlUp).Row
For i = nr To lr
wsInvoice.Cells(i, 2) = Application.VLookup(Cells(i, 1), wsPrice.Range("A:B"), 2, 0)
wsInvoice.Cells(i, 3) = (".3")
wsInvoice.Cells(i, 4).Formula = "=" & wsInvoice.Cells(i, 2).Value & "/ (1 - (C" & i & "))"
Next i
End Sub