I am creating a client register where clients can be added using a button. I also have a sort function that allows me to sort them on klantnr. But the problem is whenever I use the sort function it only sorts klantnr and the added information provided from the form keeps in place. For example, this is my userform:
(http://puu.sh/cw94k/ebf4510a24.png)
And this is my excel sheet:
(http://puu.sh/cw9nc/3a8e19a989.png)
When I add another row it sorts klantnr but it doesn't take the other values, such as Naam and Adres with it. So it needs to sort klantnr and take the other information with it
This is my code:
Private Sub btn_Toevoegen_Click()
Dim laatsteKlantNummer As Integer
Range("B4:B13").End(xlDown).Select
laatsteKlantNummer = ActiveCell.Value
ActiveCell.Offset(1, 0).Value = txtKlant + 0
ActiveCell.Offset(1, 1).Value = txtNaam
ActiveCell.Offset(1, 2).Value = txtAdres
ActiveCell.Offset(1, 3).Value = txtWoonplaats
ActiveCell.Offset(1, 4).Value = txtContact
Me.Hide
Range("B4:B13").Sort Key1:=Range("B4:B13"), Order1:=xlAscending
End Sub
use the Sort object of the sheet instead of the one from the range object:
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("B4")
ActiveSheet.Sort.SetRange Range("B4:F13")
ActiveSheet.Sort.Apply
There you can use the SetRange method to define not only the key column but also the others you want to have sortet
Related
I'm still quite new to VBA and I'm basically self-taught. I've developed a spreadsheet for work and I need a macro to allow customers to add information then the information copy to sheet 2 in descending order. This is the code I am using currently attempting to use but when I click on the “Save” macro button, the data stops copying over after two entries. Additionally, is there some code that I can input to clear the blocks so each new customer cannot see what the previous customer entered?
Private Sub CommandButton1_Click()
Dim Name As String, Org As String, POCPhone As String, Email As String, TypeofVeh As String, TotPax As String, TotCar As String, Pickup As String, DateReq As String, DateRet As String, Destination As String, YN As String, Remarks As String
Worksheets("TransReq").Select
Name = Range("B4")
Org = Range("C4")
POCPhone = Range("D4")
Email = Range("E4")
TypeofVeh = Range("F4")
TotPax = Range("G4")
TotCar = Range("H4")
Pickup = Range("I4")
DateReq = Range("J4")
DateRet = Range("K4")
Destination = Range("L4")
YN = Range("M4")
Remarks = Range("N4")
Worksheets("TransReqLog").Select
Worksheets("TransReqLog").Range("B3").Select
If Worksheets("TransReqLog").Range("B3").Offset(1, 1) <> "" Then
Worksheets("TransReqLog").Range("B3").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Name
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Org
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = POCPhone
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Email
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = TypeofVeh
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = TotPax
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = TotCar
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Pickup
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = DateReq
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = DateRet
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Destination
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = YN
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Remarks
Worksheets("TransReq").Select
Worksheets("TransReq").Range("B4").Select
End Sub
"the data stops copying over after two entries." - this means it stops here - ActiveCell.Value = POCPhone A possible reason should be, that POCPhone contains an error. E.g. - Range("D4") is probably #DIV/0 or #Value
There are 3 ways fix it (2 easy and 1 difficult) :
Write On Error Resume Next after Private Sub CommandButton1_Click() - this is really not advisable, because it will ignore every error. But it will fix it.
Rewrite the whole code, avoiding Select and ActiveCell (This is the difficult one). How to avoid using Select in Excel VBA
Write some check like this:
ActiveCell.Offset(0, 1).Select
If Not IsError(ActiveCell) Then ActiveCell.Value = DateRet
Here's a refactored version of your code that should do what you're looking for. Note that the code (including your original version) appears to assume that there is only one line (row 4) from your "TransReq" sheet to move over to the "TransReqLog" sheet:
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsLog As Worksheet
Dim rData As Range
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("TransReq")
Set wsLog = wb.Sheets("TransReqLog")
Set rData = wsData.Range("B4:N4")
wsLog.Cells(wsLog.Rows.Count, "B").End(xlUp).Offset(1).Resize(, rData.Columns.Count).Value = rData.Value
rData.ClearContents
End Sub
As a note, please familiarize yourself with How to avoid using Select in Excel VBA (Vityata also linked here in his answer)
Your code only works for two rows because of this line:
Worksheets("TransReqLog").Range("B3").End(xlDown).Select
The first line is copied successfully as the line of code isn't executed due to the IF statement.
The second line is successful as the code selects cell C3 and then performs the same operation as the keyboard shortcut Ctrl+Down which selects the next cell down that isn't empty. The code then offset by one row.
It breaks on the third attempt as the code does exactly the same as the second attempt - it starts at the empty C3 and moves down to the first cell that's not empty.
Providing all cells below are empty it's better to start at the bottom of the sheet and move upwards to the first cell that's not empty.
Worksheets("TransReqLog").Cells(Worksheets("TransReqLog").Rows.Count, 2).End(xlUp).Select
If there isn't a mixture of XL2003 and XL2007 or later then the you can just use Worksheets("TransReqLog").Cells(Rows.Count, 2).End(xlUp).Select
Having said all that, the refactor that #tigeravatar answered with is the way to go.
When data is entered (user has hit "return") into any cell in Column B, I want to insert four rows directly below the row that just had data entered into it.
I want the program to run automatically after the user has hit return on the cell. I've been having three sticking points:
Finding a way for the program to run without the user having to hit a button. I've spent a fair amount of time searching for example code to use and have found several resources, but the two examples I've used haven't seemed to work. PDCA is the sheet name, Add_Row is the macro I've written to add rows below the user-inputted data.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B3:B14]) Is Nothing Then Sheets("PDCA Tracking").Add_Row
End Sub
Actually running the Add_Row program. I get an Error 1004 Application Defined or User Defined Error. My second question is, when the user hits return, the active cell wouldn't be the one s/he just entered data in then, would it? How would I mitigate that? It would be the last row of the spreadsheet, could I find the last row and then just add rows below that?:
Sub Add_Row'Insert row below active cell
ActiveCell.Offset(1).EntireRow.Insert
Cells(ActiveCell.Offset(1), 3).Value = "Zulu"
ActiveCell.Offset(2).EntireRow.Insert
Cells(ActiveCell.Offset(2), 3).Value = "Yankee"
ActiveCell.Offset(3).EntireRow.Insert
Cells(ActiveCell.Offset(3), 3).Value = "X-Ray"
ActiveCell.Offset(4).EntireRow.Insert
Cells(ActiveCell.Offset(4), 3).Value = "Whiskey"
'Call Merge_Cells
End Sub
After I enter the data, I want to take the cells below the row where the user just added the data and merge them. (ie if the user input "banana" and I added four rows below "banana", I want JUST the four new cells under banana to merge with the cell containing "banana". I know there's a .Merge command but again, not sure of the syntax to use.
Any and all help is very appreciated!
UPDATE: I figured out how to add data below the last filled in row, I believe.
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Cells(lastRow + 1, 3).Value = "Zulu"
Cells(lastRow + 2, 3).Value = "Yankee"
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo haveError
If Target.Cells.Count = 1 And _
Not Application.Intersect(Target, [B3:B14]) Is Nothing Then
Application.EnableEvents = False
With Target
.Offset(1, 0).Resize(4, 1).Insert Shift:=xlDown
.Resize(5, 1).Merge
.VerticalAlignment = xlTop
End With
Application.EnableEvents = True
End If
Exit Sub
haveError:
Application.EnableEvents = True
End Sub
So I am currently trying to have a user input some information and put that information in a specific range based on what values in the dropdown list are selected. For example, I selected Monday, so I want the information to go in the Range A1:A12, but if they select Tuesday then go to range G1:G12.
Also, if the range is already full with data, I'd like for it to tell the user that it is full. Do not have any example code, but here is a psuedo-code example
Private Sub cbSubmit_Click()
range("A2").Select
ActiveCell.End(xlDown).Select
lastrow = ActiveCell.Row
MsgBox lastrow
If ComboBox1.Value = "Monday" Then
Cells(lastrow + 1, 1).Value = tb1.Text
Cells(lastrow + 1, 2).Value = tb2.Text
End If
If ComboBox1.Value = "Tuesday" Then
range("G2").Select
ActiveCell.End(xlDown).Select
lastrow2 = ActiveCell.Row
Cells(lastrow2 + 1, 1).Value = tb1.Text
Cells(lastrow2 + 1, 2).Value = tb2.Text
End If
End Sub
Also, in the above code, is there a better way to find the last cell in the range that is blank? This one only works if there is already data in the range and that's not always the case.
And also check some sort of CountA or something to see if the range is already full of data. Thanks in advance!
I will answer just so I can demonstrate code better.
As I said in the comments, if you want to check each value in a range, you can do so like this:
Dim c
For Each c in Range("A1:A10") 'Whatever your range to check is
If c <> vbNullString Then
'Found Data - not empty
Exit For
End If
Next
If you're just checking 2 cells as it looks like you are, you should probably just use:
If Cells(lastrow2 + 1, 1) <> vbNullString and Cells(lastrow2 + 1, 2) <> vbNullString
If you just want to add the data to the bottom of the list, your code is already getting the last row and adding to it ... so each time you call this:
ActiveCell.End(xlDown).Select
lastrow2 = ActiveCell.Row
It is getting the last row and the rest of your code adds it to the end.
One more thing. You should really replace this:
range("G2").Select
ActiveCell.End(xlDown).Select
lastrow2 = ActiveCell.Row
With this:
lastrow2 = range("G2").End(xlDown).Row
You should avoid using select as often as possible.
In my experience, it is really only necessary when displaying a different sheet.
I am programming a little and easy add client code. But when I add a client it gives me this little error where I can't get rid off. Maybe it will be an easy solution. Here is my code:
Private Sub btn_Toevoegen_Click()
Dim laatsteKlantNummer As Integer
Range("B4:B13").End(xlDown).Select
laatsteKlantNummer = ActiveCell.Value
ActiveCell.Offset(1, 0).Value = txtKlant
ActiveCell.Offset(1, 1).Value = txtNaam
ActiveCell.Offset(1, 2).Value = txtAdres
ActiveCell.Offset(1, 3).Value = txtWoonplaats
ActiveCell.Offset(1, 4).Value = txtContact
Me.Hide
Range("B4:B13").Sort Key1:=Range("B4:B13"), Order1:=xlAscending
End Sub
This code works properly but the thing happening is when it places it in the excel worksheet it is placed as text and not as number. So it gives me the error: "Number stored as text". After that I can click convert to number. Like this:(http://i.imgur.com/mfMnGFI.png) But is it possible to code it instead of clicking it all the time?
I am not sure on what line you get this error, but for example if its this one:
ActiveCell.Offset(1, 4).Value = txtContact
You can add this to 'convert' it to a number:
ActiveCell.Offset(1, 4).Value = txtContact + 0
I'm writing a Macro which loops though the Excel data, which is sorted by column A and inserts a blank row if the the values for coulmn are different from the one above. This separates my data in groups by column A.
I then want to sum the value of column d of the separated groups. I have most of my code working underneath, however its the startCell variable I am having trouble with. I know what I want to do, but cant get the logic right, can someone please help sum up those individual groups.
Many thanks
Sub PutARowInWithFormula()
Range("A3").Select
Dim startCell As Integer
Dim endCell As Integer
startCell = 3
endCell = 0
Do Until ActiveCell.Value = ""
If ActiveCell.Value = ActiveCell.Offset(-1, 0).Value Then
ActiveCell.Offset(1, 0).Select
Else
' I need the bottom code to execute only once in the loop
' startCell = ActiveCell.Row
ActiveCell.EntireRow.Insert
' move to column d
ActiveCell.Offset(0, 3).Select
endCell = ActiveCell.Row - 1
ActiveCell.Formula = "=Sum(d" & startCell & ":d" & endCell & ")"
' move back to column a
ActiveCell.Offset(0, -3).Select
'move 2 rows down
ActiveCell.Offset(3, 0).Select
End If
Loop
End Sub
I am too wondering, why you don't use a PivotTable or just create this using worksheet functions, which is possible too. Also I do not really like this attempt with selections, but its your way, and I respect that. It even seems to be a quite good example of a situation, when it might be a good idea to use them. Because right now, any other way I could think of, to do this in VBA, seems to be more complicated.
So here is a fix up of your code:
Sub PutARowInWithFormula()
Range("A2").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value = ActiveCell.Offset(-1, 0).Value Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.EntireRow.Insert
'you can use the offset directly
'by using an improved formula, you do not need to know start and end row.
ActiveCell.Offset(0, 3).Formula = _
"=SUMIF(A:A,OFFSET(INDIRECT(""A""&ROW()),-1,0),D:D)"
' move back to column a and move 2 rows down
ActiveCell.Offset(2, 0).Select
End If
Loop
End Sub
Edit
Ok, found a way easier way to do nearly the same thing:
Public Sub demo()
UsedRange.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=4
End Sub
This function is also available through the ribbon-menu -> data -> sumsum
To avoid the error-message, you just need to have a title-row for your data, like:
DATE | NAME | COUNTER | VALUE