Entering Data into a spreadsheet through a UserForm in Excel - vba

I am new to VBA in Excel, and I have a basic userform which is to place the data into the sheet. the data from the form is to enter in cell B13 through to G13, then every other entry after should be done on the next row down e.g. B14-G14.
I have this code already however it isnt entering the data into the correct cell and is repeatedly entering it on the same row...
Private Sub CommandButton1_Click()
Dim lngWriteRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
lngWriteRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
If lngWriteRow < 13 Then lngWriteRow = 13
ws.Range("B" & lngWriteRow) = TextBox1.Value
ws.Range("C" & lngWriteRow) = TextBox2.Value
ws.Range("D" & lngWriteRow) = TextBox3.Value
ws.Range("E" & lngWriteRow) = ComboBox1.Value
ws.Range("F" & lngWriteRow) = TextBox4.Value
ws.Range("G" & lngWriteRow) = ComboBox2.Value
End Sub
How would i achieve this? (There is already data on the rows below)
Thanks in advance

This line here is wrong:
lngWriteRow = ws.Cells(Rows.Count, 12) _
.End(xlUp).Offset(1, 0).Row
Because you are referring to column 12, which you do not alter - hence the row stays the same.
Use this instead
lngWriteRow = ws.Cells(Rows.Count, 2) _
.End(xlUp).Offset(1, 0).Row
Edit:
If you want an initial offset, to start the data-input # row 13, use this:
lngWriteRow = ws.Cells(Rows.Count, 2) _
.End(xlUp).Offset(1, 0).Row
if lngWriteRow < 13 then lngWriteRow = 13
You cannot use Offset(12,0), because you would use it everytime!
Edit
Just to be crystal clear, this here works on an empty sheet, when pasting the code as a worksheet-macro and hitting F5 multiple times. So, unless there is explained, what this does wrong, I consider the question solved.
Private Sub Test()
Dim lngWriteRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
lngWriteRow = ws.Cells(Rows.Count, 2) _
.End(xlUp).Offset(1, 0).Row
If lngWriteRow < 13 Then lngWriteRow = 13
ws.Range("B" & lngWriteRow) = "test"
ws.Range("C" & lngWriteRow) = "test"
ws.Range("D" & lngWriteRow) = "test"
ws.Range("E" & lngWriteRow) = "test"
ws.Range("F" & lngWriteRow) = "test"
ws.Range("G" & lngWriteRow) = "test"
End Sub
Edit
After some mailing, here is the solution to this riddle: it was not stated, that there are filled cells beneath those, which shall be entered.
So for col-B it was more like
title-row
row13
row..
row..
row63
space
other stuff
basically the suggested corrections worked - but they looked for the last filled cell in column B on the whole sheet, which was the problem.
Here is the solution to that:
lngWriteRow = ws.Cells(ws.Range("B12:B63")Rows.Count, 2) _
.End(xlUp).Offset(1, 0).Row
And to give you some explanaition on the way:
You can't use (Rows.Count,1) instead of (Rows.Count,2), because you are adding Data in the columns B-G, which is 2-7. You have to use 2-7 because of the way, you are looking for the last row. If you use 1, you're looking for the last value in column A, which does not change, when you are trying to add new data.
You can't use Offset(12,0), because this would create an offset everytime you insert data - so you would end up with rows 12 rows apart.
And finally, you can't use Rows.Count, because this is 65536 or so, and you have data beneath the data you are adding. End(xlUp) will lookup from too far down, and stop at the last cell of column B, which has data in it - but this won't be B13, unless there is no data in B14-B65536.
Hope this helps to understand the dynamics here.

Related

macro: copy paste cell if condition met

There’s one step that’s stuck, to update the stock number (column "D") in the database_ gudang (stock in the database_ gudang is added to the amount of receipt (column "K") from form_penerimaan)
The update is based on the name of the item (nama barang), so if the name of the item (column "C") in the form_penerimaan is the same as the name of the item (column "B") in the database_ gudang, the stock in database_ gudang will be updated.
but there’s a problem, which is updated only in rows 2,9,10 (yellow cell). A row of 3,4,5 should also be updated.
Thank you very much for your help.
Regards.
Sub Module1()
s = 10
OT1 = Sheets("Database_Gudang").Cells(Rows.Count, "D").End(xlUp).Row
For j = 2 To OT1
NB1 = Sheets("Database_Gudang").Cells(j, "B").Value
Sheets("Form_Penerimaan").Activate
If Cells(s, "C").Value = NB1 And Cells(s, "C").Value <> "" Then
Sheets("Form_Penerimaan").Cells(s, "Q").Copy
Sheets("Database_Gudang").Activate
Sheets("Database_Gudang").Cells(j, "G").Select
Selection.PasteSpecial Paste:=xlPasteValues
s = s + 1
End If
Next j
End Sub
Hi and Welcome to stackoverflow :)
Avoid the use of .Select and .Activate. Directly work with variables and objects. You may want to see How to avoid using Select in Excel VBA
You are facing that issue because you are not looping through the cells of the 2nd sheet.
Is this what you are trying? (UNTESTED)
I have commented the code so you may not have a problem in understanding it. If you do then share the exact error message and we will take it from there.
Sub Sample()
Dim wsThis As Worksheet, wsThat As Worksheet
Dim i As Long, j As Long
Dim wsThisLRow As Long, wsThatLRow As Long
'~~> Set your worksheets
Set wsThis = ThisWorkbook.Sheets("Database_Gudang")
Set wsThat = ThisWorkbook.Sheets("Form_Penerimaan")
'~~> Find relevant last row in both sheets
wsThisLRow = wsThis.Range("D" & wsThis.Rows.Count).End(xlUp).Row
wsThatLRow = wsThat.Range("C" & wsThat.Rows.Count).End(xlUp).Row
With wsThis
'~~> Loop through cell in Database_Gudang
For i = 2 To wsThisLRow
'~~> Loop through cell in Form_Penerimaan
For j = 10 To wsThatLRow
'~~> Compare values and get values across if applicable
If .Range("B" & i).Value = wsThat.Range("C" & j).Value Then
.Range("G" & i).Value = wsThat.Range("Q" & j).Value
Exit For
End If
Next j
Next i
End With
End Sub

If condition is met copy cell.values in one row

I'm sorry but I asked this question already yesterday, but it seems like I wasn't clear enough with my wishes, so I try it again this time.
My code Looks like this right now:
If OptionButton11.Value = True Then
Set Rng = Sheets("Table").Range(TextBox3.Value & TextBox1.Value + 1 & ":" & TextBox3.Value & lastrow)
Set kst = Sheets("Table").Range(TextBox2.Value & TextBox1.Value + 1 & ":" & TextBox2.Value & lastrow)
For Each Cell In Rng
If Cell.Value = TextBox10.Value Then
Cell.copy Cell.Offset(, 1)
Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = kst.Value
End If
Next Cell
End If
In this scenario, the user has the opportunity to use textboxes to define where his values are in the worksheet and what the macro has to look for.
Textbox1.Value defines where the headings in the worksheet are.
`
Textbox2.Value defines where the value can be found
Textbox3.Value is the criteria after the value is filtered
And
Textbox.Value 4 is the required criteria.
I would like to achieve with this code; that whenever Textbox4.Value is found in the range of Textbox3.Value, TextBox2.Value and Textbox3.Value are copied into the first free columns in the worksheet.
My Problem right now is, that
Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = kst.Value
do not copy the values in the first empty column, but add them horizontally to each freely available row in a column.
I already tried it with xlDown instead of xlToLeft but then a runtimerror (1004) appears.
Has anyone a suggestion how to fix this?
Thank you.

Extracting data from pivot table vba

I have a pivot table to aggregate "coverage" on "part" only for accepted parts.
I want then to extract the "sum of coverage" to another sheet.
I wrote the following macro:
Sub Pull_data()
'Update the pivot table
Sheets("Pivot").PivotTables("PivotTable2").PivotCache.Refresh
'clear all filters
Sheets("Pivot").PivotTables("PivotTable2").PivotFields("Accepted").ClearAllFilters
'filters only accepted items
Sheets("Pivot").PivotTables("PivotTable2").PivotFields("Accepted").CurrentPage = "YES"
'get the last row of the pivot table
Set PT = Sheets("Pivot").PivotTables("PivotTable2")
With PT.TableRange1
lngLastRow = .rows(.rows.Count).Row
End With
For i = 4 To lngLastRow
'copy the coverage to destination sheet
NEWi = i + 10
Sheets("Destination").Range("G" & NEWi) = PivotTable.GetPivotData(data_field, Range("I" & i), “Coverage”)
Next i
End Sub
I get a run time error '424', object required on
Sheets("Destination").Range("G" & NEWi) = PivotTable.GetPivotData(data_field, Range("I" & i), “Coverage”)
Which would be the proper way to write that line?
This should be :
Sheets("Destination").Range("G" & i + 10).Value = _
pT.GetPivotData("Sum of coverage", "Part", Range("I" & i).Value).Value
Because pT.GetPivotData returns a Range!
Cleaned code :
Sub Pull_data()
Dim pT As PivotTable
Set pT = Sheets("Pivot").PivotTables("PivotTable2")
With pT
'''Update the pivot table
.PivotCache.Refresh
'''clear all filters
.PivotFields("Accepted").ClearAllFilters
'''filters only accepted items
.PivotFields("Accepted").CurrentPage = "YES"
'''get the last row of the pivot table
With .TableRange1
lngLastRow = .Rows(.Rows.Count).Row
For i = .Cells(2, 1).Row To lngLastRow
Debug.Print "i=" & i & "|" & Sheets("Pivot").Range("I" & i).Value
'''copy the coverage to destination sheet
Sheets("Destination").Range("G" & i + 10).Value = _
pT.GetPivotData("Sum of coverage", "Part", Sheets("Pivot").Range("I" & i).Value).Value
Next i
End With '.TableRange1
End With 'pT
End Sub
You could try copying the entire Column from your PivotTable after it's filtered to your needs, with TableRange2 , use the Resize to a single column, and then Copy and PasteSpecial xlValues to the destination worksheet.
If the code below takes the wrong column, you can also use the Offset(0,1) to get the right one.
With PT
.TableRange2.Resize(.TableRange2.Rows.Count, 1).Copy
Worksheets("Destination").Range("G14").PasteSpecial xlValues '<-- start Pasting from Row 14
End With
Note: if the code above takes the column to the left, try the code line below:
.TableRange2.Resize(.TableRange2.Rows.Count, 1).Offset(, 1).Copy

Splitting cell with multiple data into multiple rows in more than 1 column

I have a sheet with multiple data in 1 cell this happen in a couple of columns. What I need to do is split the cell into individual rows while still keep the details from the other columns
Screen 1 shows the data i got
http://imageshack.com/a/img845/1783/wxc8.png (Screen 1)
Screen 2 is what i wish the macro to output.
http://imageshack.com/a/img842/7356/7yra.png (screen 2)
The macro i found and edited in only allows me to split 1 column and i can't get the editing of the range right. the columns that needs to be split is "J" "K" "N" and "O". The columns "A"- "I" and "L""M" just needs to copy their content to the new row.
Thank you in advance for the help.
Here the Macro im using
Sub Splt1()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("J" & Rows.Count).End(xlUp).Row
Columns("J").Insert
For i = LR To 1 Step -1
With Range("K" & i)
If InStr(.Value, Chr(10)) = 0 Then
.Offset(, -1).Value = .Value
Else
X = Split(.Value, Chr(10))
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("K").Delete
LR = Range("J" & Rows.Count).End(xlUp).Row
With Range("L1:M" & LR)
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
On Error GoTo 0
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub
The problem appears to be the with operator. It constrains your selection. Try reformulating your macro without the with and refer to the the ranges direct. For example, replace your first for loop with something like this:
For i = LR To 1 Step -1
If InStr(Range("K" & i).Value, Chr(10)) = 0 Then
Range("K" & i).Offset(, -1).Value = Range("K" & i).Value
'Range("J" ...
'Range("N" ...
'Range("O" ...
Else
K_collection = Split(Range("K" & i).Value, Chr(10))
Range("K" & i).Offset(1).Resize(UBound(K_collection)).EntireRow.Insert
Range("K" & i).Offset(, -1).Resize(UBound(K_collection) - LBound(K_collection) + 1).Value = Application.Transpose(K_collection)
'J_collection = Split(Range("J"...
'N_collection = Split(Range("N"...
'O_collection = Split(Range("O"...
End If
Next i
In general I avoid with because it tends to obscure the visual pattern of code.
You might also consider eliminating the .INSERT and .DELETE columns, and overwrite directly to the cells. When working with more than one at a time, it becomes hard to keep track which column is temporary and which one is the source. But that all depends on your preference.
Copying values for the other columns should be easy compared to this.

Excel VBA: Compiler Errors

So yesterday I posted my first SO question, and it went down like a ton of bricks. However I've picked myself up, dusted myself off, and hopefully this question will be more acceptable... :-)
I am trying to remove data duplicates from a list of Health Questionnaires I have to monitor, but the tricky bit I was struggling with was finding a duplicate in one column, AND then checking that the data on the same row, for the 3 adjacent columns were also duplicates. Storing the searched for 'duplicated row' was the bit that was throwing me off.
Here's some code I've cobbled together from other similarly-functioning scripts. I'm now in debug mode and keep getting errors thrown up... I don't have much experience of VBA, so i'm running out of options.
I'm currently getting type mismatch errors with the variable g, and also firstAddress. Why are these causing problems???
Can I call firstAddress.Row or am I barking up the wrong tree?
Here's the snippet:
g = .Find(Range("G" & i).Text, LookIn:=xlValues)
If Not g Is Nothing Then
firstAddress = g.Address
dupRow = firstAddress.Row
And here's the whole code below. Any help would be much appreciated!
Sub FindCpy()
Dim lw As Long
Dim i As Integer
Dim sh As Worksheet
Dim dupRow As Integer
Dim g As Integer
Dim firstAddress As Integer
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Used to narrow down the logical operators for duplicates
Dim rngFirst As Range
'Set the ranges
rngFirst = Range("G" & 1, "G" & lw)
Set sh = Sheets("Completed")
lw = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lw 'Find duplicates from the list.
If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) = "Complete" Then
'if COMPLETE, check the rest of the sheet for any 'in progress' duplicates...
With Worksheets("Still In Progress").rngFirst
g = .Find(Range("G" & i).Text, LookIn:=xlValues)
If Not g Is Nothing Then
firstAddress = g.Address
dupRow = firstAddress.Row
If Range("H" & dupRow).Text = Range("H" & i).Text _
And Range("I" & dupRow).Text = Range("I" & i).Text _
And Range("J" & dupRow).Text = Range("J" & i).Text Then
'select the entire row
Range.EntireRow.Select
'copy the selection
Selection.Cut
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Completed")
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
'delete the initial row
rngCell.EntireRow.Delete
Set g = .FindNext(g)
Loop While Not g Is Nothing And g.Address <> firstAddress
End If
End With
Next i
End Sub
I went through your code carefully. There were a number of problems. Some of these I think I was able to fix - there was one where I guessed what you intended to do, but for one of them I just marked it; you need to explain what you were trying to do, as you are deleting a range that you never defined...
The first problem is with the line:
If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) = "Complete" Then
The CountIf function returns a number; you are comparing this number with the string "Complete". I don't think you can ever get past this line, so the rest of the code (whether correct or not) will not execute. Not entirely clear what you are trying to do in this line, as I'm not sure when a line will be marked "Complete" - but assuming that you are interested in executing the rest of the code if the cell in A & i has the string "Complete" in it, then you probably want to do
If Range("A" & i).Text = "Complete" Then
There were a number of If - Then, With, and Loop structures that were not properly terminated with a matching End. I have tried to remedy this - make sure I did it right. Note that using proper indentation really helps to find problems like this. The space bar is your friend...
Since the Find method returns an object, the correct way to use the function is
Set g = .Find(Range("G" & i).Text, LookIn:=xlValues)
Apart from that - use Option Explicit at the top of your code, and define variables with the most restrictive (correct) type that you can. When I did this I found the error I could not correct - with the rngCell variable that was neither declared, nor ever set... It shows just how helpful it can be. Also good for catching typos - VBA will happily let you write things like
myVar = 1
MsgBox myVra + 1
The message will be 1, not 2, because of the typo... The fact that Explicit should even be an option is one of the many inexplicable design decisions made by the VBA team.
Here is your code "with most of the errors fixed". At least like this it will compile - but you must figure out what to do with the remaining error (and I can't be sure I guessed right about what you wanted to do with the cell marked "Complete").
Comments welcome.
Option Explicit
Sub FindCpy()
Dim lw As Long
Dim i As Integer
Dim sh As Worksheet
Dim dupRow As Integer
Dim g As Range
Dim firstAddress As Range
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Used to narrow down the logical operators for duplicates
Dim rngFirst As Range
'Set the ranges
rngFirst = Range("G" & 1, "G" & lw)
Set sh = Sheets("Completed")
lw = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lw 'Find duplicates from the list.
' If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) = "Complete" Then
If Range("A" & i).Text = "Complete" Then
'if COMPLETE, check the rest of the sheet for any 'in progress' duplicates...
With Worksheets("Still In Progress").rngFirst
Set g = .Find(Range("G" & i).Text, LookIn:=xlValues)
If Not g Is Nothing Then
firstAddress = g.Address
dupRow = firstAddress.Row
If Range("H" & dupRow).Text = Range("H" & i).Text _
And Range("I" & dupRow).Text = Range("I" & i).Text _
And Range("J" & dupRow).Text = Range("J" & i).Text Then
'select the entire row
g.EntireRow.Select
'copy the selection
Selection.Cut
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Completed")
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
'delete the initial row
rngCell.EntireRow.Delete ' <<<<<< the variable rngCell was never defined. Cannot guess what you wanted to do here!
Do
Set g = .FindNext(g)
Loop While Not g Is Nothing And g.Address <> firstAddress
End If ' entire row matched
End If ' Not g Is Nothing
End With ' With Worksheets("Still in Progress")
End If ' CountIf = "Complete"
Next i
End Sub
Another handy trick: when you "paste in the next available row" as you are doing with Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select, I usually find it handy to do something like this instead:
Dim destination As Range
Set destination = Worksheets("Sheetname").Range("A1")
And when you need to paste something:
destination.Select
ActiveSheet.Paste
Set destination = destination.Offset(1,0)
This way, destination is always pointing to the "next place where I can paste". I find it helpful and cleaner.