I wish to copy data from Concur into my destination worksheet - Upload to Sun:
From Concur column J into UploadtoSun column D
From Concur column P into UploadtoSun column J
etc etc
My error message was the last sentence - Application defined or object defined error.
I'm not too sure how to write the last sentence. Can anyone assist ?
Dim ConcurLastRow As Long
Set Concur = ThisWorkbook.Worksheets("Concur")
Set UploadtoSun = ThisWorkbook.Worksheets("UploadtoSun")
Dim ConcurRngF As Range
Dim ConcurRngJ As Range
Dim ConcurRngK As Range
Dim ConcurRngO As Range
Dim ConcurRngP As Range
Dim UploadtoSunRngD As Range
Dim UploadtoSunRngF As Range
Dim UploadtoSunRngJ As Range
Dim UploadtoSunRngK As Range
Dim UploadtoSunRngL As Range
ConcurLastRow = Concur.Cells(Rows.Count, 1).End(xlUp).Row
UploadtoSunLastRow = Worksheets("UploadtoSun").Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row
Set ConcurRngF = Concur.Range("F11:G" & ConcurLastRow)
Set ConcurRngJ = Concur.Range("J11:K" & ConcurLastRow)
Set ConcurRngK = Concur.Range("K11:L" & ConcurLastRow)
Set ConcurRngO = Concur.Range("O11:P" & ConcurLastRow)
Set ConcurRngP = Concur.Range("P11:Q" & ConcurLastRow)
Set UploadtoSunRngD = UploadtoSun.Range("D2:E" & UploadtoSunLastRow)
Set UploadtoSunRngF = UploadtoSun.Range("F2:G" & UploadtoSunLastRow)
Set UploadtoSunRngJ = UploadtoSun.Range("J2:K" & UploadtoSunLastRow)
Set UploadtoSunRngK = UploadtoSun.Range("K2:L" & UploadtoSunLastRow)
Set UploadtoSunRngL = UploadtoSun.Range("L2:M" & UploadtoSunLastRow)
Worksheets("UploadtoSun").Range("UploadtoSunRngD").Copy Worksheets("Concur").Range("ConcurRngJ").Value
you could do something like this
Sub Copydata()
Dim lastRow As Long
lastRow = Worksheets("Concur").Range("J:Z").Find("*", , , , xlByRows, xlPrevious).Row
'copy range
Worksheets("Concur").Range("J1:" & "J" & lastRow).Copy Destination:=Worksheets("UploadtoSun").Range("D1")
'copy entire column
Worksheets("Concur").Range("J:J").Copy Destination:=Worksheets("UploadtoSun").Range("K:K")
End Sub
how to get the last row Excel VBA - selecting range to last completely blank row
Related
I'm attempting to change any range selection that the user makes to column A only. I would like to keep the same row selction.
Sub update_test()
Dim ActSheet As Worksheet
Dim SelRange As Range
Set ActSheet = ActiveSheet
Set SelRange = Selection.Columns(1)
'My selected range is $S$1832:$S$1842
Debug.Print SelRange.Address
'I was hoping that the .Columns(1) would change my range to $A$1832:$A$1842
'But it is still $S$1832:$S$1842
End Sub
Managed to do it with offset and errors, seems a bit longwinded
Sub update_test()
Dim SelRange As Range
Set SelRange = Selection
Debug.Print SelRange.Address
On Error Resume Next
For i = -100 To 0 Step 1
Set SelRange = SelRange.Offset(0, i)
If Err.Number = 0 Then i = 0
Next i
On Error GoTo 0
Debug.Print SelRange.Address
end sub
I have this form to enter new data to a table.
I would like to warn the user when he is entering an invoice number that already exist. Here is the code I have but its not working:
Private Sub CommandButton1_Click()
Dim L As Long
Dim Code As String
Dim TextBox2 As Long
Dim valFormula As String
valFormula = "=COUNTIFS($F12:$F1702,F1702,$D12:$D1702,D1702)=1"
If MsgBox("Confirm?", vbYesNo, "Confirming new invoice") = vbYes Then
With Worksheets("FACTURE")
L = Sheets("FACTURE").Range("D65535").End(xlUp).Row + 1 'Pour placer le nouvel enregistrement _ la premi_re ligne de tableau non vide
End With
With Me
Range("D" & L).Validation
.Add Type:=xlValidateCustom, _
AlertStyle:=xlValidAlertWarning, _
Formula1:="=COUNTIFS($F12:$F1702,F1702,$D12:$D1702,D1702)=1"
.InputTitle = ""
.ErrorTitle = "Duplicate alert"
.InputMessage = ""
.ErrorMessage = "This invoice number already exist. Continue?"
Range("B" & L).Value = .ComboBox2 & .ComboBox3
Range("C" & L).Value = (Now)
Range("D" & L).Value = .TextBox2
Range("E" & L).Value = .TextBox3
Range("F" & L).Value = .TextBox4
Range("G" & L).Value = .TextBox5
Range("K" & L).Value = .ComboBox1
Range("L" & L).Value = .ComboBox2
Range("M" & L).Value = .ComboBox3
Range("N" & L).Value = .TextBox9
Range("O" & L).Value = .TextBox10
Range("R" & L).Value = .TextBox39
Range("P" & L).Value = .TextBox40
Range("C" & L).Interior.ColorIndex = 0
If .OptionButton1 Then
FormatCell Range("B" & L), xlThemeColorAccent3
ElseIf .OptionButton2 Then
FormatCell Range("B" & L), xlThemeColorAccent1
ElseIf .OptionButton3 Then
FormatCell Range("B" & L), xlThemeColorAccent4
Else
FormatCell Range("B" & L), xlThemeColorAccent2
End If
End With
End If
End Sub
Any advice?
As Comintern suggested, use Find() method of Range object, with code like:
Set f = rngToSerachIn.Find(what:=factureNo, LookIn:=xlValues, lookat:=xlWhole)
where
f is a range variable where to store the range with the searched value
rngToSerachIn is the range where to search the value
factureNo is the value to search for
furthermore it seems to me your invoices will be stored in rows from 12 downwards, so it could be useful to write a generic function to get first empty cell in a given column of a given worksheet ranging from a certain row
Since it'd be a good practice to demand specific tasks to Sub/Function to improve both code readability and maintenance, you could do that for:
getting first empty row after last non empty one starting from a given row in a given column of a given worksheet
validating invoice number
filling worksheet ranges
formatting invoice cell
as follows:
Option Explicit
Private Sub CommandButton1_Click()
Dim L As Long
Dim factureWs As Worksheet
If MsgBox("Confirm?", vbYesNo, "Confirming new invoice") = vbNo Then Exit Sub
Set factureWs = Worksheets("FACTURE") '<--| set the worksheet you want to work with
L = GetLastNonEmptyRow(factureWs, "D", 12) + 1 '<--| get passed worksheet first empty row after last non empty one in column "D" from row 12 (included)
If L > 12 Then If Not CheckDuplicate(Me.TextBox2, factureWs.Range("D12:D" & L - 1)) Then Exit Sub '<--| exit if duplicated non accepted by the user
FillRanges factureWs, L '<--| fill worksheet ranges with userfom controls values
FormatInvoice factureWs.Range("B" & L) '<--| color invoice cell depending on option buttons values
End Sub
Function GetLastNonEmptyRow(ws As Worksheet, colIndex As String, firstRow As Long) As Long
Dim lastRow As Long
With ws
lastRow = .Cells(.Rows.Count, colIndex).End(xlUp).row ' <--| get last non empty row in given column
If lastRow = 1 Then If IsEmpty(.Range(colIndex & 1)) Then lastRow = 0 '<--| handle the case of an empty column
If lastRow < firstRow Then lastRow = firstRow - 1 '<--| handle the case the last non empty row is above the first passed one
End With
GetLastNonEmptyRow = lastRow
End Function
Function CheckDuplicate(factureNo As String, rng As Range) As Boolean
Dim f As Range
Set f = rng.Find(what:=factureNo, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
CheckDuplicate = MsgBox("This invoice number already exist!" & vbCrLf & vbCrLf & "Continue?", vbExclamation + vbYesNo, "Duplicate alert") = vbYes
Else
CheckDuplicate = True
End If
End Function
Sub FormatInvoice(rng As Range)
Dim thColor As XlThemeColor
With Me
Select Case True
Case .OptionButton1
thColor = xlThemeColorAccent3
Case .OptionButton2
thColor = xlThemeColorAccent1
Case .OptionButton3
thColor = xlThemeColorAccent4
Case Else
thColor = xlThemeColorAccent2
End Select
End With
FormatCell rng, thColor
End Sub
Sub FillRanges(ws As Worksheet, L As Long)
With ws
.Range("C" & L).Value = (Now)
.Range("D" & L).Value = Me.TextBox2
.Range("E" & L).Value = Me.TextBox3
.Range("F" & L).Value = Me.TextBox4
.Range("G" & L).Value = Me.TextBox5
.Range("K" & L).Value = Me.ComboBox1
.Range("L" & L).Value = Me.ComboBox2
.Range("M" & L).Value = Me.ComboBox3
.Range("N" & L).Value = Me.TextBox9
.Range("O" & L).Value = Me.TextBox10
.Range("R" & L).Value = Me.TextBox39
.Range("P" & L).Value = Me.TextBox40
End With
End Sub
you may find it useful and follow this pattern in your subsequent coding
Basically what I am trying to do is, sending an email for every used row on the target worksheet, each row has the details of the addresses, subject line, table with values etc.
So I can't seem to get it working, as it only dispatches one email from the first target row (2nd row).
I have tried using a combination of For Each and For i = 1 to LR which aren't working. I suspect it is to do with the cell references.
Here is the code:
Sub TestEmail1()
Application.ScreenUpdating = False
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim ccAddresses As Range, ccCell As Range, ccRecipients As String
Dim rngeSubject As Range, SubjectCell As Range, SubjectContent As Variant
Dim rngeBody As Range, bodyCell As Range, bodyContent As Variant
Dim Table1 As Range
Dim i As Integer
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
Set rng = ActiveSheet.UsedRange
LRow = rng.Rows.Count
For i = 2 To LRow
Set Table1 = Worksheets(1).Range("K1:R1")
Set Table2 = Worksheets(2).Range("K" & i & ":" & "R" & i)
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
'set sheet to find address for e-mails as I have several people to
'mail to
Set rngeAddresses = ActiveSheet.Range("B" & i)
For Each rngeCell In rngeAddresses.Cells
strRecipients = strRecipients & ";" & rngeCell.Value
Next
Set ccAddresses = ActiveSheet.Range("C" & i)
For Each ccCell In ccAddresses.Cells
ccRecipients = ccRecipients & ";" & ccCell.Value
Next
Set rngeSubject = ActiveSheet.Range("D" & i)
For Each SubjectCell In rngeSubject.Cells
SubjectContent = SubjectContent & SubjectCell.Value
Next
Set rngeBody = ActiveSheet.Range("E" & i)
For Each bodyCell In rngeBody.Cells
bodyContent = bodyContent & bodyCell.Value
Next
'set Importance
'aEmail.Importance = 2
'Set Subject
aEmail.Subject = rngeSubject
'Set Body for mail
'aEmail.Body = bodyContent
aEmail.HTMLBody = bodyContent & "<br><br><br>" & RangetoHTML_ (Table1)
aEmail.To = strRecipients
aEmail.CC = ccRecipients
aEmail.Send
Exit Sub
Next i
Next c
End Sub
There is an Exit Sub at the end of your inner loop that makes the code exit from the procedure after the first iteration:
Sub TestEmail1()
...
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
...
For i = 2 To LRow
...
Exit Sub
Next i
Next c
End Sub
Remove it and processing should continue as desired.
This one has me stumped. I am populating a Listbox with a range and then formatting column 4 as d/mm/yyyy. This works fine if all cells in column 4 have a date. As some cells that are populated into the Listbox are in fact blank the sub crashes when it hits these cells. I have tried various if and else statements to skip the activecell if blank with no luck.
Grateful for any assistance.
Alex V
Sub populate_listbox_1()
Dim I As Long
Dim I2 As Long
Dim list_count As Long
Dim MyData As Range
Dim r As Long
With edit_report_input.compliments_listbox
.ColumnCount = 17
.ColumnWidths = "70;300;75;90;80;80;100;0;0;0;0;0;0;0;0;20;0"
.RowSource = ""
Set MyData = ActiveSheet.Range("A4:Q498") 'Adjust the range accordingly
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 1) = "" Then
.RemoveItem r
End If
Next r
End With
For I = 0 To edit_report_input.compliments_listbox.ListCount - 1
edit_report_input.compliments_listbox.List(I, 4) = Format(DateValue(edit_report_input.compliments_listbox.List(I, 4)), "d/mm/yyyy")
Next I
date_rec_compliment = Format(date_rec_compliment, "d/mm/yyyy")
End Sub
you can always check before changing the format. See if below snippet helps
For I = 0 To edit_report_input.compliments_listbox.ListCount - 1
if edit_report_input.compliments_listbox.List(I, 4) <> "" Then
edit_report_input.compliments_listbox.List(I, 4) = Format(DateValue(edit_report_input.compliments_listbox.List(I, 4)), "d/mm/yyyy")
End If
Next I
I'm trying to copy and paste a range, to create a 28 by 28 grid of numbers "rotating" the values so that each time the range is pasted into the next column, the range is moves down by one row and the last value "overflows" back to the top of the next row, I've got this far but am stumped on the overflow part (i' relative newbie to VBA)
Sub Test()
Dim oRange As Range
Set oRange = ActiveSheet.Range("A1:A28")
Dim i As Integer
For i = 1 To 28
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Next i
End Sub
Also I need to copy and paste values and formatting of the cells
Hope you guys can help
Thanks
Dan
Sub Test()
Dim oRange As Range
Dim startColumn As String
Dim rangeStart As Integer
Dim rangeEnd As Integer
Dim cellCount As Integer
Dim i As Integer
startColumn = "A"
rangeStart = 1
rangeEnd = 28
cellCount = rangeEnd - rangeStart + 1
For i = 1 To cellCount - 1
Set oRange = ActiveSheet.Range(startColumn & rangeStart & _
":" & startColumn & (rangeEnd - i))
oRange.Copy
oRange.Offset(i, i).PasteSpecial xlPasteAll
Set oRange = ActiveSheet.Range(startColumn & (rangeEnd - i + 1) & _
":" & startColumn & rangeEnd)
oRange.Copy
oRange.Offset((-1 * cellCount) + i, i).PasteSpecial xlPasteAll
Next i
End Sub
EDIT:
to insert a blanck row at index 'i':
Rows(i & ":" & i).Select
Selection.Insert Shift:=xlDown
to insert 5 rows at the top of the worksheet insert a row 5 times at index 1:
For i = 1 To 5
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Next