I have the following code so far to subtract one column from another, but then need to take that result and if D is negative then F = D + F else E = E + D
Sub PopCol()
Range("D3:D19").Formula = "=RC[-1]-RC[-2]" 'D=C-B
I'm Lost! Been trying different formats for range in this and have had no luck-HELP!
Thank You!
Is this what you are trying?
Sub PopCol()
Dim rng As Range, aCell As Range
Set rng = Range("D3:D19")
rng.Formula = "=RC[-1]-RC[-2]"
For Each aCell In rng
Select Case aCell.Value
Case Is < 0 '<~~ If value in D is negative
'~~> F = F + D
aCell.Offset(, 2).Value = aCell.Offset(, 2).Value + aCell.Value
Case Else
'~~> E = E + D
aCell.Offset(, 1).Value = aCell.Offset(, 1).Value + aCell.Value
End Select
Next
End Sub
Try below code :
Sub PopCol()
For i = 3 To 19
Range("D" & i) = CLng(Range("C" & i) - Range("B" & i))
If (Range("D" & i) < 0) Then
Range("F" & i) = Range("D" & i) + Range("F" & i)
Else
Range("E" & i) = Range("E" & i) + Range("D" & i)
End If
Next
End Sub
Related
I have some problems with excel and VBA, in that don't know have much knowledge. I copied text from pdf and it's awful.
I have cells which contain some text.
The problem is that the text from one paragraph is broken down over several cells. At the beginning of each paragraph is a word in bold (e.g. CLR.) which describes the rest of the text. As such, it defines where each paragraph should start. How I can merge these cells into one?
I see
I want
Sub MergeText()
Dim strMerged$, r&, j&, i&
r = 1
Do While True
If Cells(r, 1).Characters(1, 1).Font.Bold Then
strMerged = "": strMerged = Cells(r, 1)
r = r + 1
While (Not Cells(r, 1).Characters(1).Font.Bold) And Len(Cells(r, 1)) > 0
strMerged = strMerged & Cells(r, 1)
r = r + 1
Wend
i = i + 1: Cells(i, 2) = strMerged
Cells(i, 2).Characters(1, InStr(1, strMerged, ".", vbTextCompare)).Font.Bold = True
Else
Exit Do
End If
Loop
End Sub
Modify (if needed) and try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, j As Long, Count As Long
Dim str As String
With ThisWorkbook.Worksheets("Sheet1") 'Change sheet name if needed
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1
If (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) = Left(.Range("A" & i - 1), 1) Then
Count = 0
For j = 1 To Len(.Range("A" & i - 1))
If .Range("A1").Characters(j, 1).Font.FontStyle = "Bold" Then
Count = Count + 1
Else
Exit For
End If
Next j
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
With .Characters(Start:=1, Length:=Count).Font
.FontStyle = "Bold"
End With
End With
.Rows(i).EntireRow.Delete
ElseIf (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) <> Left(.Range("A" & i - 1), 1) Then
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
End With
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
I'm trying to make multiple selections from Sheet2. The value is from the same column but different rows (thinking if using ActiveCell.Offset(1,0) will be feasible).
My code takes the value from an ActiveCell select and runs a macro compares it to another sheet (Sheet10) with some information to copy and paste in a target sheet (Sheet5).
The following is the code that I have right now.
a = Sheet10.Cells(Rows.Count, 1).End(xlUp).Row
c = Sheet2.Cells(Rows.Count, 5).End(xlUp).Row
For Each cell In Range(ActiveCell, ActiveCell.Offset(1, 0))
For i = 2 To a 'from Row 1 to the last row of "DMP"
Debug.Print ("i = " & i)
If cell.Value = Sheet10.Cells(i, 1).Value Then 'if selected cell matches (i,1) of "Sheet10 (DMP)"
Debug.Print ("ActiveCell =" & ActiveCell.Value)
For k = 1 To 20 'from Column 1 to Column 20
Debug.Print ("k = " & k)
For r = 1 To c 'from Row 1 to the last row of "Sheet 2(LightOn SKU)"
Debug.Print ("r = " & r)
If Sheet10.Cells(i, k).Value = Sheet2.Cells(r, 4).Value Then 'if value of (i,k) of "Sheet10 (DMP)" = (r,4) of "Sheet2 (LightOn SKU)"
Sheet2.Range("A" & r & ":G" & r).Copy
Sheet5.Activate
b = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
Sheet5.Cells(b + 1, 1).Select
ActiveSheet.Paste
Range("A" & r & ":L" & r).Borders.Color = vbBlack
End If
Next
Next
End If
Next
Next
Right now, it's running on an endless loop.
Still Unclear
Sub ACCopy2()
Dim a As Long
Dim c As Long
Dim r As Long
Dim i As Long
Dim k As Integer
Dim b As Long
a = Sheet10.Cells(Rows.Count, 1).End(xlUp).Row
c = Sheet2.Cells(Rows.Count, 5).End(xlUp).Row
For r = 1 To c ' from Row 1 to the last row of "Sheet 2(LightOn SKU)"
Debug.Print ("r = " & r)
For i = 2 To a ' from Row 1 to the last row of "DMP"
Debug.Print ("i = " & i)
' if selected cell matches (i,1) of "Sheet10 (DMP)"
If Sheet2.Cells(r, 1).Value = Sheet10.Cells(i, 1).Value Then
Debug.Print ("Sheet2 =" & Sheet2.Cells(r, 1).Value)
For k = 1 To 20 ' from Column 1 to Column 20
Debug.Print ("k = " & k)
' if value of (i,k) of "Sheet10 (DMP)" = (r,4) of
' "Sheet2 (LightOn SKU)"
If Sheet10.Cells(i, k).Value = Sheet2.Cells(r, 4).Value Then
With Sheet5
b = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
Sheet2.Range("A" & r & ":G" & r).Copy .Cells(b + 1, 1)
.Range("A" & r & ":L" & r).Borders.Color = vbBlack
End With
End If
Next
End If
Next
Next
End Sub
Hi I would like to apply the below vba to the entire column AK instead of just AK1
Sub Tidy_Cell()
Range("AK1") = Replace(Range("AK1"), Chr(13), "")
For x = 1 To Len(Range("AK1"))
If Mid(Range("AK1"), x, 1) = Chr(10) And Mid(Range("AK1"), x + 1, 1) = Chr(10) Then
Range("AK1") = Left(Range("AK1"), x) & Mid(Range("AK1"), x + 2)
End If
Next
With Range("A1")
.Value = Mid(.Value, 1)
.VerticalAlignment = xlTop
End With
End Sub
Thanks a lot for any help!
I would put all your code into a Loop that checks column AK
dim lLastUsed As Long
lLastUsed = Cells(1048576, "AK").End(xlUp).Row
For i = 1 to lLastused
//insert your code here
Next i
Remember every spot you defined it to be Range("AK1") you need to change it to Range("AK" & i) so it ends up something like this:
Sub Tidy_Cell()
Dim lLastUsed As Long
lLastUsed = Cells(1048576, "AK").End(xlUp).Row
For i = 1 to lLastUsed
Range("AK" & i) = Replace(Range("AK" & i), Chr(13), "")
For x = 1 To Len(Range("AK" & i))
If Mid(Range("AK" & i), x, 1) = Chr(10) And Mid(Range("AK" & i), x + 1, 1) = Chr(10) Then
Range("AK" & i) = Left(Range("AK" & i), x) & Mid(Range("AK" & i), x + 2)
End If
Next x
Next i
With Range("A1")
.Value = Mid(.Value, 1)
.VerticalAlignment = xlTop
End With
End Sub
Hope this helps you out
I have 2 columns and need a VBA code to sum the values of unique elements in column "A", print the unique elements in column "D" and sum in column "E" :-
Name Value Name Sum
A 1 A 13
A 2 B 7
B 1 C 3
B 3
C 2
A 1
B 2
A 3
B 1
A 2
A 4
C 1
Can anyone help on this, this is what I tried :-
Sub CountSum()
Dim c As Collection, wf As WorksheetFunction, _
K As Long, N As Long, i As Long, _
v As Variant, d As Collection, y As Variant
Set c = New Collection
Set d = New Collection
Set wf = Application.WorksheetFunction
K = 2
N = Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next
For i = 2 To N
v = Cells(i, "A").Value
y = Cells(i, "B").Value
c.Add v, CStr(v)
d.Add y
If Err.Number = 0 Then
Cells(K, "D").Value = v
Cells(K, "E").Value = wf.CountIf(Range("A:A"), v)
Cells(K, "F").Value = wf.Sum(Range("B:B"), y)
K = K + 1
Else
Err.Number = 0
End If
Next i
On Error GoTo 0
End Sub
Using a Dictionary:
Sub Tester()
Dim rng As Range, dict As Object
Set rng = Range(Range("A2"), Cells(Rows.Count, 1).End(xlUp)).Resize(, 2)
Set dict = SubTotals(rng, 1, 2)
DumpDict dict, Range("D1")
End Sub
Function SubTotals(rng As Range, colKey As Long, colVal As Long) As Object
Dim rv As Object, rw As Range, k, v
Set rv = CreateObject("scripting.dictionary")
For Each rw In rng.Rows
k = rw.Cells(colKey).Value
v = rw.Cells(colVal).Value
If Not IsError(k) And Not IsError(v) Then
If Len(k) > 0 And IsNumeric(v) Then
rv(k) = rv(k) + v
End If
End If
Next rw
Set SubTotals = rv
End Function
Sub DumpDict(dict As Object, rng As Range)
Dim i As Long, k
i = 0
For Each k In dict.keys
With rng.Cells(1)
.Offset(i, 0).Value = k
.Offset(i, 1).Value = dict(k)
End With
i = i + 1
Next
End Sub
next code works for me, I hope this will help you. This will work perfectly if at column A there are not blank cells between values.
Sub SUM()
Dim i, j, k As Integer
i = 2
j = 2
Range("D1").Value = "NAME"
Range("E1").Value = "VALUE"
'copy the first value of column A to column D
Range("D2").Value = Range("A2").Value
'cycle to read all values of column B and sum it to column E; will run until find a blank cell
While Range("A" & i).Value <> ""
'this check if actual value of column A is equal to before value of column A, if true just add the column B value to E
'else, look for the row in column D where is the same value of column A, if it doesn't exist code create the value
'in column D and E
If Range("A" & i).Value = Range("A" & i - 1).Value Then
Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
Else
flag = 1
While Range("D" & flag).Value <> ""
If Range("A" & i).Value = Range("D" & flag).Value Then
j = flag
Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
flag = Range("D1").End(xlDown).Row
Else
j = 0
End If
flag = flag + 1
Wend
If j = 0 Then
Range("D1").End(xlDown).Offset(1, 0).Value = Range("A" & i).Value
Range("E1").End(xlDown).Offset(1, 0).Value = Range("B" & i).Value
j = Range("E1").End(xlDown).Row
End If
End If
i = i + 1
Wend
MsgBox "End"
End Sub
I have multiple Excel workbooks that contain about 8,000 rows so it would be nice to use a macro.
Basically, if any row has a zero (0) in all columns (at the same time) B, D, E, I, J, and K it will delete.
Here is what I have so far...way too new with VB to figure out.
Sub DeleteRowsZeros()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
If (Range("B") = "0" And Range("D" & i) = "0" And Range("E" & i) = "0" And Range("I" & i) = "0" _
And Range("J" & i) = "0" And Range("K" & i) = "0") Then Rows(i).Delete
Next i
End Sub
Try this :
Sub DeleteRowsZeros()
Dim cell As Range, notZeroColumns As Range, row As Range
Set row = Range("A" & Rows.Count).End(xlUp).EntireRow.Offset(1, 0)
Set notZeroColumns = Range("B:B,D:E,I:k")
While row.row <> 1
Set row = row.Offset(-1, 0)
For Each cell In Intersect(row, notZeroColumns)
If cell.Text <> "0" Then GoTo continueLbl
Next
row.Offset(1, 0).Delete
continueLbl:
Wend
End Sub
EDIT : bugfixe