Excel VBA Range(Cell).Value=sum 1004:Application-Defined Or Object-Defined - vba

Function ChangeColVal(ByVal Rng As Range, ByVal ValueToChange As Integer)
Dim Cell1, Cell2 As String
Dim PosOfColon, TotalCell, Sum As Integer
PosOfColon = InStr(1, Rng.Address, ":")
Cell1 = Left(Rng.Address, PosOfColon - 1)
Cell2 = Right(Rng.Address, Len(Rng.Address) - PosOfColon)
If Left(Cell1, 2) = Left(Cell2, 2) Then
TotalCell = Rng.Count
For i = 0 To TotalCell
If IsNumeric(Range(Cell1).Offset(i, 0).Value) = False Then
GoTo 112:
End If
Cell2 = Range(Cell1).Offset(i, 0).Address
Sum = Range(Cell2).Cells.Value + ValueToChange
On Error GoTo 111
'Here getting error...
Range(Cell2).Value = Sum
GoTo 112
111:
MsgBox (Err.Number & ":" & Err.Description)
112:
Next i
Else
MsgBox ("Select Column only...")
End If
End Function
I wants to increase or decrease cell value of selected range.
I am getting error in line Range(Cell2).Value = Sum
Edit
thanx for reply, in line Range(Cell2).Value = Sum, Cell2 is pointing to cell address like $E$6.
If there is any option other than that pls let me know

ok Mihir. You cannot use a UDF (User Defined Function) to modify other cells then the one the formula is used in. However, there is a workaround it by calling your function from a sub. I will show you how to do it.
Open a new workbook and make your spreadsheet look like the picture below.
Fill in some random numbers in column A of Sheet1
Then open VBE and create a new module ( Project Explorer > Insert > Module ) and paste the code from below
Option Explicit
Sub ChangeColumnValue()
Dim rng As Range
Set rng = Selection
Dim inp As String
inp = InputBox("Value to change:")
Call ChangeColVal(rng, CLng(inp))
End Sub
Private Function ChangeColVal(ByRef rng As Range, ByVal ValueToChange As Long)
Dim Cell1, Cell2 As String
Dim PosOfColon, TotalCell, Sum As Long
PosOfColon = InStr(1, rng.Address, ":")
Cell1 = Left(rng.Address, PosOfColon - 1)
Cell2 = Right(rng.Address, Len(rng.Address) - PosOfColon)
If Left(Cell1, 2) = Left(Cell2, 2) Then
TotalCell = rng.Count
Dim i&
For i = 0 To TotalCell - 1
If Not IsNumeric(Range(Cell1).Offset(i, 0).Value) Then
GoTo 112:
End If
Cell2 = Range(Cell1).Offset(i, 0).Address
Sum = Range(Cell2).Cells.Value + ValueToChange
On Error GoTo 111
Range(Cell2).Value = Sum
GoTo 112
111:
MsgBox (Err.Number & ":" & Err.Description)
112:
Next i
Else
MsgBox ("Select Column only...")
End If
End Function
Then, go back to your spreadsheet and select your range with your mouse like this:
Ok, now hit ALT + F8 to View Macros and run the ChangeColumnValue macro.
You will be prompt for a Value to Change and all cells within selected range will be Increased/Decreased by that Value.
and your final result if you type 5 in the prompt box will look like this
Good luck!

finally here is the solution.
Sub ChangeRowValues()
Dim rng As Range
Dim R As Range
Dim ValueToChange As Long
Dim Cell1, Cell2 As String
Dim PosOfColon, TotalCell, Sums, i As Integer
Set rng = Selection
ValueToChange = Val(InputBox("Enter Number to Change:", "Enter Number...", 0))
PosOfColon = InStr(1, rng.Address, ":")
Cell1 = Left(rng.Address, PosOfColon - 1)
Cell2 = Right(rng.Address, Len(rng.Address) - PosOfColon)
If UCase(Left(Cell1, 1)) = UCase(Left(Cell2, 1)) Then
TotalCell = rng.Count
For i = 0 To TotalCell - 1
'To Chnage Values of Row....
Range(Cell1).Offset(0, i).Select
'To Chnage Values of Colum....
'Range(Cell1).Offset(i,0).Select
If IsNumeric(ActiveCell.Value) = True Then
ActiveCell.Value = Val(ActiveCell.Value) + ValueToChange
End If
Next i
Else
MsgBox ("Select Row only...")
End If
End Sub

range() function input is cell address, for example, range(a1:b2;g1:h4), you cannot input some result in it.

Related

Trying to combine two VBA programs together

I have two programs for the same Excel spreadsheet and would like to combine them into one program but I just can't seem to get that to work. If anyone could assist it sure would be appreciated. What I have tried is to take the out the Sub do_it() at the second program and the End Sub out of the first program. I have included everything here so you can see both complete programs.
Sub do_it()
n = [E15]
Set reg = CreateObject("VBScript.RegExp")
reg.Pattern = "^[0-9]*\-[0-9]*$"
reg.Global = True
For Each cell In Range("A15:A30,C15:C30,E15:E30,G15:G30,I15:I30")
strVAL = cell.Offset(0, 1).Value
If cell.Value = n And reg.test(strVAL) Then
Range(“E15”).Value = StrVal
MsgBox "Found a postivive result in " & cell.Address
End If
Next
End Sub
-
Sub do_it()
Dim n, sht As Worksheet, cell As Range, num, tmp, rngDest As Range
Set sht = ActiveSheet
n = sht.Range("E15")
For Each cell In sht.Range("A15:A30,C15:C30,E15:E30,G15:G30,I15:I3 0").Cells
tmp = cell.Offset(0, 1).Value
If cell.Value = n And tmp Like "*#-#*" Then
'get the first number
num = CLng(Trim(Split(tmp, "-")(0)))
Debug.Print "Found a positive result in " & cell.Address
'find the next empty cell in the appropriate row
Set rngDest = sht.Cells(num, sht.Columns.Count).End(xlToLeft).Offset(0, 1)
'make sure not to add before col K
If rngDest.Column < 12 Then Set rngDest = sht.Cells(num, 12)
cell.Offset(0, 1).Copy rngDest
Exit For
End If
Next
End Sub
I am not sure what exactly you want to do, but to do multiple things it is better to break it down into smaller subroutines or functions, for example, you should do this. To run both you need to call the sub main. Remember you cannot have duplicate sub or function names:
Sub main()
Call FirstCode
Call SecondCode
End Sub
Sub FirstCode()
n = [E15]
Set reg = CreateObject("VBScript.RegExp")
reg.Pattern = "^[0-9]*\-[0-9]*$"
reg.Global = True
For Each cell In Range("A15:A30,C15:C30,E15:E30,G15:G30,I15:I30")
StrVal = cell.Offset(0, 1).Value
If cell.Value = n And reg.test(StrVal) Then
Range(“E15”).Value = StrVal
MsgBox "Found a postivive result in " & cell.Address
End If
Next
End Sub
Sub SecondCode()
Dim n, sht As Worksheet, cell As Range, num, tmp, rngDest As Range
Set sht = ActiveSheet
n = sht.Range("E15")
For Each cell In sht.Range("A15:A30,C15:C30,E15:E30,G15:G30,I15:I3 0").Cells
tmp = cell.Offset(0, 1).Value
If cell.Value = n And tmp Like "*#-#*" Then
'get the first number
num = CLng(Trim(Split(tmp, "-")(0)))
Debug.Print "Found a positive result in " & cell.Address
'find the next empty cell in the appropriate row
Set rngDest = sht.Cells(num, sht.Columns.Count).End(xlToLeft).Offset(0, 1)
'make sure not to add before col K
If rngDest.Column < 12 Then Set rngDest = sht.Cells(num, 12)
cell.Offset(0, 1).Copy rngDest
Exit For
End If
Next
End Sub

Copy a range into a single column - values only

Hello I am trying to copy a range into a single column. The range is a mix of blank cells and cells with values.I only want to copy and paste the cells with values and I would it to find the first blank cell and want it to walk itself down the column from there.
The code I have right now (besides taking forever) pastes in the first row.
Dim i As Integer
i = 1
ThisWorkbook.Worksheets("amount date").Select
For Row = 51 To 100
For col = 2 To 1000
If Cells(Row, col).Value <> "" Then
Cells(Row, col).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
End If
Next
Next
Do While Worksheets("sheet 2").Range("G" & i).Value <> ""
i = i + 1
Loop
End Sub
This will work:
Sub qwerty()
Dim i As Long, r As Long, c As Long
i = 1
ThisWorkbook.Worksheets("amount date").Select
For r = 51 To 100
For c = 2 To 1000
If Cells(r, c).Value <> "" Then
Cells(r, c).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
i = i + 1
End If
Next
Next
End Sub
Perhaps this will be a little faster (even though it seems to have been slow arriving).
Sub CopyRangeToSingleColumn()
' 20 Oct 2017
Dim LastRow As Long
Dim LastClm As Long
Dim Rng As Range, Cell As Range
Dim CellVal As Variant
Dim Spike(), i As Long
With ThisWorkbook.Worksheets("amount date")
With .UsedRange.Cells(.UsedRange.Cells.Count)
LastRow = Application.Max(Application.Min(.Row, 100), 51)
LastClm = .Column
End With
Set Rng = .Range(.Cells(51, "A"), .Cells(LastRow, LastClm))
End With
ReDim Spike(Rng.Cells.Count)
For Each Cell In Rng
CellVal = Trim(Cell.Value) ' try to access the sheet less often
If CellVal <> "" Then
Spike(i) = CellVal
i = i + 1
End If
Next Cell
If i Then
ReDim Preserve Spike(i)
With Worksheets("sheet 2")
LastRow = Application.Max(.Cells(.Rows.Count, "G").End(xlUp).Row, 2)
.Cells(LastRow, "G").Resize(UBound(Spike)).Value = Application.Transpose(Spike)
End With
End If
End Sub
The above code was modified to append the result to column G instead of over-writing existing cell values.
Do you need copy the whole row into one cell, row by row? For each loop shall be faster. I guess, this should work
Sub RowToCell()
Dim rng As Range
Dim rRow As Range
Dim rRowNB As Range
Dim cl As Range
Dim sVal As String
Set rng = Worksheets("Sheet3").Range("$B$51:$ALN$100") 'check this range
For Each rRow In rng.Rows
On Error Resume Next
Set rRowNB = rRow.SpecialCells(xlCellTypeConstants)
Set rRowNB = Union(rRow.SpecialCells(xlCellTypeFormulas), rRow)
On Error GoTo 0
For Each cl In rRowNB.Cells
sVal = sVal & cl.Value
Next cl
Worksheets("sheet4").Range("G" & rRow.Row - 50).Value = sVal
sVal = ""
Next rRow
End Sub
its quick for this range.

Comparing cells with array in VBA

Firstly I am storing all the data that I want into an array, then I'll compare it with a column; if it matches then i will take the offset of the value and place it into another column.
But here at the array, I am experiencing "invalid qualifier" error. What am I doing wrong?
Sub database_updator()
Dim dataa As Range, dataCel1 As Range, dataj As Range, datacel2 As Range, datazc As Range, datacel3 As Range, SrchRngaa As Range, cel As Range
Dim data As String, datatext As String, PDS_NAME As String, Database_data As String
Dim n As Integer, xx As Integer, z As Integer
Set dataa = Range("a16:a100")
Set datazc = Range("zc17:zc50")
Set SrchRngaa = Range("a16:a100")
Dim arr(1 To 85) As String
x = 16
For n = 1 To 85 'storing data into array
arr(n) = Range("yx" & x).Value
x = x + 1
Next n
' loop thorugh cells in column
For Each dataCel1 In datazc
For n = 1 To 85
If arr(n) = dataCel1.Value Then
datatext = "true"
Exit For
End If
Next n
' check if current value in column has a match in another column
If datatext = "true" Then
PDS_NAME = arr(n).Value ' ERROR OCCURS HERE
Database_data = dataCel1.Offset(0, 2).Value
For Each cel In SrchRngaa
If PDS_NAME = "" Then
Exit For
ElseIf cel.Value = PDS_NAME Then
cel.Offset(0, 2).Value = Database_data
Exit For
End If
Next cel
End If
Next dataCel1
End Sub
PDS_NAME = arr(n).Value
this should be changed to:
PDS_NAME = arr(n)

Adding Text after every line on the same cell

I have the following Excel cells:
D001
D002
D003
345
(In the same cell)
I need to add a string of text after every line on the same cell, like this:
D001 First Text
D0002 Second Text
D003 Third Text
345 Fouth Text
I found a code which allows me to count how many lines there are on the same cell, but I dont find any way of using it to write after the text on each of those lines:
Public Sub CountLines()
Dim H1 As Double
Dim H2 As Double
Dim row As Long
row = 1
While Cells(row, 1).Value <> ""
With Cells(row, 1)
.WrapText = False
H1 = .height
.WrapText = True
H2 = .height
.Offset(0, 1).Value = H2 / H1
End With
row = row + 1
Wend
End Sub
I guess the right way of doing it is by using a For to write text before any change of line he finds (Ch(10)) on VBA, but i havent been able to make it work
Thanks for the help.
Adding Text To Count Line Breaks
This code will loop through all cells with any value in Column A.
I have recreated your data set in my Excel:
The code will break up each line, add which line it is, and move on to the next:
Below is the code:
Sub AddText()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim myCell As Variant, myRange As Range, tempArr() As String
Dim i As Integer
Set myRange = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
For Each myCell In myRange
tempArr = Split(myCell, Chr(10))
myCell.Value = ""
For i = 0 To UBound(tempArr)
tempArr(i) = tempArr(i) & " text " & i
If i = UBound(tempArr) Then
myCell.Value = myCell.Value & tempArr(i)
Else: myCell.Value = myCell.Value & tempArr(i) & Chr(10)
End If
Next i
Next myCell
End Sub
If you want it to count from base 1 instead of base 0, change the lines myCell.Value = myCell.Value & tempArr(i) (and the following one in the If statement) to myCell.Value = myCell.Value & tempArr(i) + 1
I should mention again that this is already set up for a dynamic range in Column A. Meaning if you add more data formatted the same way in A2, the code will apply itself to that as well, all the way to the last set of data in column A.
Dim arr() As String
Dim arr2() As String
arr = Split(yourCell, char(10))
arr2 = Split("first, second, third", "," )
For i = 1 To UBound(arr)
debug. print arr(i) + arr2(i)
next i
after rebuilding the new string the new string assign it back to the cell
This will only place (random) text after each line in the cell. But it gives you a place to start.
Option Explicit
Public Sub RePrint()
Dim MyRange As Range
Dim MyArray As Variant
Dim i As Long
Set MyRange = Range("A1")
MyArray = Split(MyRange, Chr(10))
For i = LBound(MyArray) To UBound(MyArray)
MyArray(i) = MyArray(i) & " Text" & i
Next i
MyRange = Join(MyArray, Chr(10))
End Sub
you could use this function:
Function AddText(rng As Range, textsArr As Variant) As String
Dim nTexts As Long, nLines As Long, iLine As Long
Dim linesArr As Variant
nTexts = UBound(textsArr) - LBound(textsArr) + 1
With rng
linesArr = Split(.Value, vbLf)
nLines = UBound(linesArr) - LBound(linesArr) + 1
If nTexts < nLines Then nLines = nTexts
For iLine = 1 To nLines
linesArr(LBound(linesArr) - 1 + iLine) = linesArr(LBound(linesArr) - 1 + iLine) & " " & textsArr(LBound(textsArr) - 1 + iLine)
Next iLine
AddText = Join(linesArr, vbLf)
End With
End Function
to be exploited as follows
Option Explicit
Sub main()
Dim cell As Range
Dim additionalTexts As Variant
additionalTexts = Array("First Text", "Second Text", "Third Text", "Fourth Text") '<--| set your array of additional text, each element index corresponding to to be processed cell content line
With Worksheets("ADDTEXT") '<--| reference your relevant worksheet (change "ADDTEXT" to your actual relevant worksheet name)
For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) '<--| reference its column "A" cells form row 1 down to last not empty row
cell.Value = AddText(cell, additionalTexts) '<--| process
Next cell
End With
End Sub
This will but in the text "First Line", "Second Line"... after each line. The way it is set up now uses the value in A1 and replaces the value in A1. It is ideal for cells with 4 lines or less, but it will work with more.
Sub appendCharacters()
Dim lines() As String
Dim text As String
lines = Split(Range("A1"), Chr(10))
Range("A1").Value = ""
For i = LBound(lines) To UBound(lines)
Select Case i
Case 0
text = " First Line"
Case 1
text = " Second Line"
Case 2
text = " Third Line"
Case 3
text = " Fourth Line"
Case Else
text = " Another Line"
End Select
lines(i) = lines(i) + text
Range("A1").Value = Range("A1").Value + lines(i)
If i <> UBound(lines) Then
Range("A1").Value = Range("A1").Value + vbCrLf
End If
Next i
End Sub

Add unique number to excel datasheet using VBA

I have two columns of numbers, together they will be unique (composite key). I would like to create an unique ID number (third column) similar to how MS Access would use a primary key. I would like to do this in VBA but I am stuck on how to do it.
My VBA in excel isn't very good so hopefully you can see what I've started to attempt. it may be completely wrong... I don't know?
I don't know how to make the next concatenation and I am unsure about how to go down to the next row correctly.
Sub test2()
Dim var As Integer
Dim concat As String
concat = Range("E2").Value & Range("F2").Value
var = 1
'make d2 activecell
Range("D2").Select
Do Until concat = ""
'if the concat is the same as the row before we give it the same number
If concat = concat Then
var = var
Else
var = var + 1
End If
ActiveCell.Value = var
ActiveCell.Offset(0, 1).Select
'make the new concatination of the next row?
Loop
End Sub
any help is appreciated, thanks.
Give the code below a try, I've added a loop which executes for each cell in the E Column. It checks if the concat value is the same as the concat value in the row above and then writes the id to the D cell.
Sub Test2()
Dim Part1 As Range
Dim strConcat As String
Dim i As Long
i = 1
With ThisWorkbook.Worksheets("NAME OF YOUR SHEET")
For Each Part1 In .Range(.Cells(2, 5), .Cells(2, 5).End(xlDown))
strConcat = Part1 & Part1.Offset(0, 1)
If strConcat = Part1.Offset(-1, 0) & Part1.Offset(-1, 1) Then
Part1.Offset(0, -1).Value = i
Else
i = i + 1
Part1.Offset(0, -1).Value = i
End If
Next Part1
End With
End Sub
Something like this should work, this will return a Unique GUID (Globally Unique Identifier):
Option Explicit
Sub Test()
Range("F2").Select
Do Until IsEmpty(ActiveCell)
If (ActiveCell.Value <> "") Then
ActiveCell.Offset(0, 1).Value = CreateGUID
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Public Function CreateGUID() As String
CreateGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function
If you walk down column D and examine the concatenated values from column E and F with the previous row, you should be able to accomplish your 'primary key'.
Sub priKey()
Dim dcell As Range
With Worksheets("Sheet12")
For Each dcell In .Range(.Cells(2, 4), .Cells(Rows.Count, 5).End(xlUp).Offset(0, -1))
If LCase(Join(Array(dcell.Offset(0, 1).Value2, dcell.Offset(0, 2).Value2), ChrW(8203))) = _
LCase(Join(Array(dcell.Offset(-1, 1).Value2, dcell.Offset(-1, 2).Value2), ChrW(8203))) Then
dcell = dcell.Offset(-1, 0)
Else
dcell = Application.Max(.Range(.Cells(1, 4), dcell.Offset(-1, 0))) + 1
End If
Next dcell
End With
End Sub
You could use collections as well.
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range, LstRw As Long
Dim Cell As Range
Dim vNum As Variant, c As Range, y
LstRw = Cells(Rows.Count, "E").End(xlUp).Row
Set Rng = Range("E2:E" & LstRw)
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value & Cell.Offset(, 1), CStr(Cell.Value & Cell.Offset(, 1))
Next Cell
On Error GoTo 0
y = 1
For Each vNum In cUnique
For Each c In Rng.Cells
If c & c.Offset(, 1) = vNum Then
c.Offset(, -1) = y
End If
Next c
y = y + 1
Next vNum
End Sub