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
Related
I'm having a bit of trouble with this and I'm not sure why...
My code (such that it is, a work in progress) is getting stuck on this line:
Set starRange = .Range(Cells(title), Cells(LR, 3))
Can I not use a range variable to set a new range in this way?
Sub cellPainter()
Dim ws As Worksheet
Dim starRange, titleRange, found As Range
Dim errorList() As String
Dim i, LR As Integer
i = 0
ReDim errorList(i)
errorList(i) = ""
For Each ws In ActiveWorkbook.Worksheets
With ws
LR = .Cells(.Rows.Count, "C").End(xlUp).Row
Set titleRange = .Range("C4")
If InStr(1, titleRange, "Title", vbBinaryCompare) < 1 Then
Set found = .Range("C:C").Find("Title", LookIn:=xlValues)
If Not found Is Nothing Then
titleRange = found
Else
errorList(i) = ws.Name
i = i + 1
ReDim Preserve errorList(i)
End If
End If
Set starRange = .Range(Cells(titleRange), Cells(LR, 3))
For Each cell In starRange
If InStr(1, cell, "*", vbTextCompare) > 0 Then Range(cell, cell.Offset(0, 2)).Interior.ColorIndex = 40
If InStr(1, cell, "*", vbTextCompare) = 0 Then Range(cell, cell.Offset(0, 2)).Interior.ColorIndex = 0
Next cell
End With
Next ws
If errorList(0) <> "" Then
txt = MsgBox("The following worksheets were missing the Title row, and no colour changes could be made:" & vbNewLine)
For j = 0 To i
txt = txt & vbCrLf & errorList(j)
Next j
MsgBox txt
End If
End Sub
Edit:
Rory cracked it!
When using a variable inside Range, the Cells property is not required:
Set starRange = .Range(titleRange, .Cells(LR, 3))
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.
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
Screen shot of what I want:
I want to time stamp each line as a change gets made so I can upload to a central file all lines that have been updated after a certain time. Since one asset might have multiple rows for each sub component, the user can fill in one line and autofill/copy paste to the relevant lines beneath. The rows might not be in a continuous range (e.g. when filtered).
The code I've got works great for changing one cell at a time and it works for a range but incredibly slowly.
This sub is called by worksheet_change shown in full below.
Sub SetDateRow(Target As Range, Col As String)
Dim TargetRng As Range
Dim LastCol, LastInputCol As Integer
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
End With
For Each TargetRng In Target.Cells
If TargetRng.Cells.Count > 1 Then
Application.EnableEvents = True
Exit Sub
Else
Application.EnableEvents = False
Cells(TargetRng.Row, LastCol - 2) = Now()
Cells(TargetRng.Row, LastCol - 1).Value = Environ("username")
Cells(TargetRng.Row, LastCol).Value = Target.Address
End If
Next
Application.EnableEvents = True
End Sub
Target.Cells.Address returns the range (including non-visible cells), but I can't work out how to split this into individual, visible cells that I can loop through.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Errorcatch
Dim TargetRng As Range
Dim LastCol, LastInputCol, LastRow As Integer
Dim LastInputColLetter As String
Dim ContinueNewRow
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
LastInputCol = LastCol - 3
If LastInputCol > 26 Then
LastInputColLetter = Chr(Int((LastInputCol - 1) / 26) + 64) & Chr(((LastInputCol - 1) Mod 26) + 65)
Else
LastInputColLetter = Chr(LastInputCol + 64)
End If
For Each TargetRng In Target.Cells
If TargetRng.Row <= 2 Then
Exit Sub
End If
If TargetRng.Column <= LastInputCol Then
SetDateRow Target, LastCol - 3
If TargetRng.Count = 1 Then
Application.EnableEvents = False
'
Dim cmt As String
' If Target.Value = "" Then
' Target.Value = " "
'
' End If
'----------------------------------------------------------------
If Intersect(TargetRng, Range("AC3:AC10000")) Is Nothing Then ' need to make column into variables in the code based on column name
Application.EnableEvents = True
Else
Application.EnableEvents = False
Cells(TargetRng.Row, "Z") = Now() 'Date booking was made column
Cells(TargetRng.Row, "AD").Value = Cells(Target.Row, "AD").Value + 1 ' iteration column
End If
'----------------------------------------------------------------
If TargetRng.Comment Is Nothing Then
cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "*"
Else
cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "* " & TargetRng.Comment.Text
End If
With TargetRng
.ClearComments
.AddComment cmt
End With
End If
End If
Application.EnableEvents = True
Next
Exit Sub
Errorcatch:
MsgBox Err.Description
Application.EnableEvents = True
End Sub
I have done some adjustments to your code (see comments within code)
This solution assumes the following:
Sample data has a two rows header and fields to be updated have the following titles located at row 1 (adjust corresponding lines in code if needed):
Date Change Made, Who Made Change and Last Cell Changed as per picture provided.
Booked Date, BkdDte Change and Iteration for columns AC, Z and AD respectively (this names are used for testing purposes, change code to actual names)
I have also combined both procedures into a common one in order to avoid the inefficient approach of looping twice the cells of the changed range. Let me know if they must remain separated and will do the necessary adjustments.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Wsh As Worksheet, rCll As Range
Dim iDteChn As Integer, iWhoChn As Integer, iLstCll As Integer
Dim iBkdDte As Integer, iBkdChn As Integer, iBkdCnt As Integer
Dim sCllCmt As String
Dim lRow As Long
On Error GoTo ErrorCatch
Rem Set Application Properties
Application.ScreenUpdating = False 'Improve performance
Application.EnableEvents = False 'Disable events at the begining
Rem Set Field Position - This will always returns Fields position
Set Wsh = Target.Worksheet
With Wsh
iDteChn = WorksheetFunction.Match("Date Change Made", .Rows(1), 0)
iWhoChn = WorksheetFunction.Match("Who Made Change", .Rows(1), 0)
iLstCll = WorksheetFunction.Match("Last Cell Changed", .Rows(1), 0)
iBkdDte = WorksheetFunction.Match("Booked Date", .Rows(1), 0) 'Column of field "Booked date" (i.e. Column `AC`)
iBkdChn = WorksheetFunction.Match("BkdDte Change", .Rows(1), 0) 'Column of field "Booked date changed" (i.e. Column `Z`)
iBkdCnt = WorksheetFunction.Match("Iteration", .Rows(1), 0) 'Column of field "Iteration" (i.e. Column `AD`)
End With
Rem Process Cells Changed
For Each rCll In Target.Cells
With rCll
lRow = .Row
Rem Exclude Header Rows
If lRow <= 2 Then GoTo NEXT_Cll
Rem Validate Field Changed
Select Case .Column
Case Is >= iLstCll: GoTo NEXT_Cll
Case iDteChn, iWhoChn, iBkdChn, iBkdCnt: GoTo NEXT_Cll
Case iBkdDte
Rem Booked Date - Set Count
Wsh.Cells(lRow, iBkdChn) = Now()
Wsh.Cells(lRow, iBkdCnt).Value = Cells(.Row, iBkdCnt).Value + 1
End Select
Rem Update Cell Change Details
Wsh.Cells(lRow, iDteChn).Value = Now()
Wsh.Cells(lRow, iWhoChn).Value = Environ("username")
Wsh.Cells(lRow, iLstCll).Value = .Address
Rem Update Cell Change Comments
sCllCmt = Now & vbCrLf & Environ("UserName") & " *" & .Value & "*"
If Not .Comment Is Nothing Then sCllCmt = sCllCmt & .Comment.Text
.ClearComments
.AddComment sCllCmt
End With
NEXT_Cll:
Next
Rem Restate Application Properties
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrorCatch:
MsgBox Err.Description
Rem Restate Application Properties
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Do let me know of any questions you might have about the resources used in this procedure.
You could use something like this:
Sub SetDateRow(Target As Range, Col As String)
Dim TargetRng As Range
Dim LastCol As Long
Dim LastInputCol As Long
Dim bEvents As Boolean
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
End With
bEvents = Application.EnableEvents
Application.EnableEvents = False
If Target.Cells.Count > 1 Then
For Each TargetRng In Target.SpecialCells(xlCellTypeVisible).Areas
Cells(TargetRng.Row, LastCol - 2).Resize(TargetRng.Rows.Count, 1).Value = Now()
Cells(TargetRng.Row, LastCol - 1).Resize(TargetRng.Rows.Count, 1).Value = Environ("username")
Cells(TargetRng.Row, LastCol).Resize(TargetRng.Rows.Count, 1).Value = Target.Address
Next
Else
Cells(Target.Row, LastCol - 2).Value = Now()
Cells(Target.Row, LastCol - 1).Value = Environ("username")
Cells(Target.Row, LastCol).Value = Target.Address
End If
Application.EnableEvents = bEvents
End Sub
but make sure you call it before or after the loop in your change event, not inside it as you are now!
I need to do some calculations for each cell in two aligned columns in EXCEL 2010 by VBA on Win7.
Write the result in a cell of another column.
My code:
Set result_rng = Range("H2:H10")
Set aRng = Range("C2:C10")
Set bRng = Range("F2:F10")
For Each aCell, bCell, cCell In aRng, bRng, result_rng // **error here**
cEll.Value = Cdl(aCell.Value) - Cdl(b.Cell.Value)
Next aCell
I also need to check wether F column is "NULL", if yes, I will not do calculation and just update a counter.
update new error of caling a sub
find_max rng1:=rng // error !!! ByRef argu mismatch
Sub find_max(ByRef rng1 As Range)
Dim dblM As Double
dblM = -9E+307
Dim maxCellAddress As String
For Each Cell In rng
If IsNumeric(c) Then
If dblMax < CDbl(Cell.Value) And Cell.Value <> "" Then
dblM = CDbl(Cell.Value)
maxCellAddress = (Cell.Address)
End If
End If
Next Cell
End Sub
Any help would be appreciated.
UPDATE 1
Try this one:
Sub test()
Dim rng As Range, c As Range
Set rng = Range("C2:C10")
For Each c In rng
If c.Offset(0, 3).Value <> "NULL" Then
c.Offset(0, 5).Value = c.Value - c.Offset(0, 3).Value
End If
Next c
End Sub
where c.Offset(0, 3) means offset to the right on 3 columns, i.e. if c refers to cell in column C, then c.Offset(0, 3) gives you corresponding value from column F and c.Offset(0, 5) gives you corresponding value from column H.
If it seems too tricky, you can use this one instead:
Range("H" & c.Row).Value = c.Value - Range("F" & c.Row).Value
UPDATE 2
Sub test()
Dim result_rng As Range, c As Range
Dim dblM As Double
Dim maxCellAddress As String
Set result_rng = Range("H2:H10")
dblM = -9E+307
For Each c In result_rng
If IsNumeric(c) Then
If dblM < CDbl(c.Value) And c.Value <> "" Then
dblM = CDbl(c.Value)
maxCellAddress = c.Address
End If
End If
Next c
End Sub