I have developed below code and i want that it should paste the value as negative instead of positive value. I looked around but nothing similar found.
It should be negative ws.Cells(r, "I").Value
Sub copyandpasteasnegative()
Dim ws As Worksheet, LastRow As Long, r As Long
Set ws = Sheet1
LastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For r = 2 To LastRow
If ws.Cells(r, "B") = "KIO" Then
ws.Cells(r, "I").Value = ws.Cells(r + 1, "I").Value
End If
Next
End Sub
Simple multiplication:
ws.Cells(r, "I").Value = -1 * ws.Cells(r + 1, "I").Value
Probably best to use IsNumeric before attempting to multiply:
With ws.Cells(r + 1, "I")
If IsNumeric(.Value) Then
ws.Cells(r, "I").Value = .Value * -1
End If
End With
I think you can do this by changing only one line. Try this:
ws.Cells(r, "I").Value = 0 - ws.Cells(r + 1, "I").Value
Related
I have a user Form through which I am able to upload transactions into a cashflow worksheet. By using cDbl in two controls I am able to ensure that amounts are added to the Worksheet in a format that can be used in calculations. However, by nature these fields are mutually exclusive (Credit & Debit). cDbl requires a value to be populated in each control so I am looking for a method that will check the value of each of the two relevant controls and to ignore them when the value is Null
Private Sub cmdAddRecord_Click()
'Used to add new transation records to the database
lastrow = Sheets("Spending Account").Range("A" & Rows.Count).End(xlUp).Row
Cells(lastrow + 1, "A").Value = DTPicker1
Cells(lastrow + 1, "B").Value = cboVendorDetails
Cells(lastrow + 1, "C").Value = cboTransactionType
Cells(lastrow + 1, "D").Value = CDbl(Me.txtTransactionAmountDebit)
Cells(lastrow + 1, "E").Value = CDbl(Me.txtTransactionAmountCredit)
Cells(lastrow + 1, "F").Value = cboTransactionStatus
With ActiveSheet
Application.Goto Reference:=.Cells(.Rows.Count, "A").End(xlUp).Offset(-20), Scroll:=True
End With
Unload Me
frmRegularTransactions.Show
End Sub
I would welcome any solution
Private Sub cmdAddRecord_Click()
'Used to add new transation records to the database
Dim r As Long, sCredit As String, sDebit As String
sDebit = Me.txtTransactionAmountDebit
sCredit = Me.txtTransactionAmountCredit
With Sheets("Spending Account")
r = 1 + .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(r, "A").Value = DTPicker1
.Cells(r, "B").Value = cboVendorDetails
.Cells(r, "C").Value = cboTransactionType
.Cells(r, "F").Value = cboTransactionStatus
' credit or debit
If Len(sDebit) > 0 Then
If Len(sCredit) > 0 Then
MsgBox "Warning - Both Credit and Debit", vbExclamation
Else
.Cells(r, "D").Value = CDbl(sDebit)
End If
ElseIf Len(sCredit) > 0 Then
.Cells(r, "E").Value = CDbl(sCredit)
End If
If r > 21 Then
Application.Goto Reference:=.Cells(r - 20, "A"), Scroll:=True
End If
End With
Unload Me
frmRegularTransactions.Show
End Sub
I want to combine duplicate rows with the same A and C columns values and sum their cells values for the column B (by adding the value of the textbox2 from the duplicate to the original). My problem is about the condition of the "If" in the Loop. It doesn't consider those conditions when I have duplicates and just add a new row. Is there a better way to do this?
Private Sub CommandButton1_Enter()
ActiveSheet.Name = "Sheet1"
Dim lastrow As Long
With Sheets("Sheet2")
lastrow = .Cells(Rows.Count, "H").End(xlUp).Row
For x = lastrow To 3 Step -1
For y = 3 To lastrow
If .Cells(x, 1).Value = .Cells(y, 1).Value And .Cells(x, 3).Value = .Cells(y, 3).Value And x > y Then
.Cells(y, 8).Value = .Cells(y, 8).Value + TextBox2.Text
.Cells(y, 2).Value = .Cells(y, 2).Value + TextBox2.Text
.Rows(lastrow).EntireRow.Delete
Else
.Cells(lastrow + 1, 8).Value = TextBox2.Text
.Cells(lastrow + 1, 2).Value = TextBox2.Text
.Cells(lastrow + 1, 1).Value = TextBox1.Text
.Cells(lastrow + 1, 3).Value = TextBox3.Text
Exit For
End If
Next y
Next x
End With
End Sub
Here's a picture of the data
There's no blank cell in the column H (I changed the color of the font to make it invisible).
Create a primary key by joining the 2 columns with tilde ~ and use a Dictionary Object to locate duplicates.
Option Explicit
Private Sub CommandButton1_Click()
Dim wb As Workbook, ws As Worksheet
Dim iLastRow As Long, iRow As Long, iTarget As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet2")
iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
Dim dict As Object, sKey As String
Set dict = CreateObject("Scripting.Dictionary")
' build dictionary and
' consolidate any existing duplicates, scan up
For iRow = iLastRow To 3 Step -1
' create composite primary key
sKey = LCase(ws.Cells(iRow, 1).Value) & "~" & Format(ws.Cells(iRow, 3).Value, "yyyy-mm-dd")
If dict.exists(sKey) Then
iTarget = dict(sKey)
' summate and delete
ws.Cells(iTarget, 2) = ws.Cells(iTarget, 2) + ws.Cells(iRow, 2)
ws.Cells(iTarget, 8) = ws.Cells(iTarget, 8) + ws.Cells(iRow, 8)
ws.Rows(iRow).EntireRow.Delete
Else
dict(sKey) = iRow
End If
Next
' add new record from form using dictionary to locate any existing
iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
sKey = LCase(TextBox1.Text) & "~" & Format(DateValue(TextBox3.Text), "yyyy-mm-dd")
If dict.exists(sKey) Then
iTarget = dict(sKey)
ws.Cells(iTarget, 2) = ws.Cells(iTarget, 2) + TextBox2.Text
ws.Cells(iTarget, 8) = ws.Cells(iTarget, 8) + TextBox2.Text
Else
iTarget = iLastRow + 1
ws.Cells(iTarget, 1) = TextBox1.Text
ws.Cells(iTarget, 2) = TextBox2.Text
ws.Cells(iTarget, 3) = TextBox3.Text
ws.Cells(iTarget, 8) = TextBox2.Text
End If
End Sub
Application Match for one column works but for 2 columns is giving me error
With Sht
LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
For i = LastRow To 2 Step -1
DupRow = Application.Match(Cells(i, 9).Value, Range(Cells(1, 9), Cells(i - 1, 9)), 0)
DoEvents
If Not IsError(DupRow) Then
Cells(i, 8).Value = Cells(i, 8).Value + Cells(DupRow, 8).Value
Cells(i, 9).Value = Cells(i, 9).Value + Cells(DupRow, 9).Value
Rows(DupRow).Delete
End If
Next i
End With
for 2 columns Error runtime 1004
DupRow = Application.Match(Cells(i, 4).Value & Cells(i, 5).Value, Range(Cells(1, 4) & Cells(1, 5), Cells(i - 1, 4) & Cells(i - 1, 5)), 0)
What is the correct way of doing this?
In my opinion it's better to use dictionary for that, which has built-in method for managing keys, so it can be used to get unique values:
Sub teest()
Dim val As String
Set dict = CreateObject("Scripting.Dictionary")
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1
val = Cells(i, 1).Value & Cells(i, 2).Value
If dict.Exists(val) Then
Rows(i).Delete
Else
dict.Add val, 0
End If
Next
End Sub
Can someone help me if this is possible to do?
Logic is: If ColA = 1 and ColC >=1 then it should copy the entire row and insert new row below the last blank cell before meeting the next cell that contains then 1 will become 0.
Raw:
Final output should be:
I tried to put it as text but it doesn't seem right. the code i have for now is only this, its my first project tho. my code is still incomplete as i don't know what to do next. i tried a lot of codes but not working. here's the code:
Dim asd As Integer
Dim LastRow As Long
LastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For zxc = 2 To C
If Cells(zxc, "A").Value = 1 And Cells(zxc, "C").Value >= 1 Then
asd = asd + 1
End If
Next zxc
Dim AddCountRow As Long
AddCountRow = LastRow + asd
For i = 2 To AddCountRow
Dim A As Long
A = Worksheets("Sheet1").Cells(i, "A").Value
Dim B As Long
B = Worksheets("Sheet1"). Cells(i + 1, "D"). Value
If A >= 1 And B >= 1 Then
Cells(i + 1, "A").EntireRow.Insert
i = i + 1
End If
Next i
End Sub
Thank you so much guys!
This is a different approach. Considering maybe you have data below and
lastrow could not be reliable.
Look for the <<< Customize this >>> where I set the first cell where you have the header.
This code covers the data in the sample image:
Sub CopyInsertRows()
Dim colAValue As String
Dim colBValue As String
Dim colCValue As String
Dim colDValue As String
Dim initialCell As String
Dim rowCounter As Long
' <<< Customize this >>>
initialCell = "A4"
' Loop through all cells
For rowCounter = 2 To Rows.Count
If Range(initialCell).Cells(rowCounter, 1).Value <> vbNullString Then
colAValue = Range(initialCell).Cells(rowCounter, 1).Value
colBValue = Range(initialCell).Cells(rowCounter, 2).Value
colCValue = Range(initialCell).Cells(rowCounter, 3).Value
colDValue = Range(initialCell).Cells(rowCounter, 4).Value
ElseIf Range(initialCell).Cells(rowCounter, 1).Value = vbNullString And Range(initialCell).Cells(rowCounter + 1, 1).Value <> vbNullString Then
Range(initialCell).Cells(rowCounter + 1).EntireRow.Insert
Range(initialCell).Cells(rowCounter + 1, 1).Value = "0"
Range(initialCell).Cells(rowCounter + 1, 2).Value = colBValue
Range(initialCell).Cells(rowCounter + 1, 3).Value = colCValue
Range(initialCell).Cells(rowCounter + 1, 4).Value = colDValue
rowCounter = rowCounter + 1
End If
If Range(initialCell).Cells(rowCounter, 4).Value = vbNullString Then
Range(initialCell).Cells(rowCounter, 1).Value = "0"
Range(initialCell).Cells(rowCounter, 2).Value = colBValue
Range(initialCell).Cells(rowCounter, 3).Value = colCValue
Range(initialCell).Cells(rowCounter, 4).Value = colDValue
Exit For
End If
Next rowCounter
End Sub
This code covers the data in the sample linked file:
Sub CopyInsertRows()
Dim sourceRow As Range
Dim initialCell As String
Dim dateColumnLetter As String
Dim dateColumnNumber As Integer
Dim rowCounter As Long
' <<< Customize this >>>
initialCell = "A1" ' First cell of header row
dateColumnLetter = "AA" ' Where
' Get column number
dateColumnNumber = Range(dateColumnLetter & 1).Column
' Loop through all cells
For rowCounter = 2 To Rows.Count
If Range(initialCell).Cells(rowCounter, 1).Value <> vbNullString Then
' Store row values
Set sourceRow = Range(initialCell).Range("A" & rowCounter & ":" & dateColumnLetter & rowCounter)
ElseIf Range(initialCell).Cells(rowCounter, 1).Value = vbNullString And Range(initialCell).Cells(rowCounter + 1, 1).Value <> vbNullString Then
' Insert new row
Range(initialCell).Cells(rowCounter + 1).EntireRow.Insert
' Duplicate source row
Range(initialCell).Range("A" & rowCounter + 1 & ":" & dateColumnLetter & rowCounter + 1).Value = sourceRow.Value
' Replace first cell
Range(initialCell).Range("A" & rowCounter + 1).Value = "0"
rowCounter = rowCounter + 1
End If
If Range(initialCell).Cells(rowCounter, dateColumnNumber).Value = vbNullString Then
' Duplicate source row
Range(initialCell).Range("A" & rowCounter & ":Y" & rowCounter).Value = sourceRow.Value
' Replace first cell
Range(initialCell).Range("A" & rowCounter + 1).Value = "0"
Exit For
End If
Next rowCounter
End Sub
You will be inserting rows so work from the bottom up.
Sub addLines()
Dim i As Long, lr As Long, n As Long
With Worksheets("sheet5")
'collect last data row
lr = .Cells(.Rows.Count, "D").End(xlUp).Row + 1
'loop through the rows backwards, inserting rows and transferring values
For i = lr To 3 Step -1
If i = lr Or .Cells(i, "A") <> vbNullString Then
n = Application.Match(1E+99, .Range("A:A").Resize(i - 1, 1))
.Cells(i, "A").Resize(1, 4).Insert Shift:=xlDown
.Cells(i, "A").Resize(1, 4) = .Cells(n, "A").Resize(1, 4).Value
.Cells(i, "A") = 0
End If
Next i
End With
End Sub
i have to sort data from sheet1 to sheet2 with reference to non-empty cell in column A. and
i have written code for it as below:
Sub polo()
Dim lastrow As Long
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = Sheets("Sheet1").Cells(i - 1, 2).Value
j = j + 1
End If
Next i
End Sub
But the problem is, i am getting result as in column D of sheet2.
I want result as shown in column E.
Please help.
Try this version:
Sub polo()
Dim lastrow As Long
Dim sTemp as String
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = stemp
j = j + 1
Else
stemp = Sheets("Sheet1").Cells(i, 2).Value
End If
Next i
End Sub