I am trying to insert new row under a particular text(selected from userform) with the new text but getting an error "Object variable or With block variable not set" in the line "fvalue.Value = Me.txtremark.Value".
Please help me to find where exactly the mistake I did in the Code. I was trying to find many ways but failed.
Excel Table:
Required Output:
Private Sub cmdadd_Click()
Dim fvalue As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets("Sheet1")
wks.Activate
Set fvalue = wks.Range("B:B").Find(What:=Me.txtremark.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
fvalue.Value = Me.txtremark.Value
fvalue.Offset(1).EntireRow.Insert Shift:=xlDown
fvalue.Offset(0, 1).Value = Me.txtplace.Value
End Sub
Try:
Option Explicit
Sub test()
Dim Position As Range, rngToSearch As Range
Dim strToFound As String
'Change strToFound value
strToFound = "Test"
With ThisWorkbook.Worksheets("Sheet1")
Set rngToSearch = .Range("B:B")
Set Position = rngToSearch.Find(strToFound, LookIn:=xlValues, Lookat:=xlWhole)
If Not Position Is Nothing Then
Debug.Print Position.Row
.Rows(Position.Row).Offset(1).EntireRow.Insert
End If
End With
End Sub
Try using a separate variable to pass values to the worksheet, or just refer to the textbox.
Additionally, activating (and selecting) is not necessary and will hurt your macro's speed and is prone to errors.
Option Explicit
Private Sub cmdadd_Click()
Dim fvalue As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets("Sheet1")
Set fvalue = wks.Range("B:B").Find(What:=Me.txtremark.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
If Not fvalue Is Nothing Then
wks.Rows(fvalue.Row + 1).EntireRow.Insert
wks.Cells(fvalue.Row + 1, fvalue.Column + 1).Value = Me.txtremark.Value
End If
End Sub
I have taken the liberty to check if the value is found in the first place
Related
I have a worksheet where Appt Note text is very lengthy. I need to place it in a row of nine merged cells.
I'm trying to check all the cells in column A for the value "Appt Note:" then merge the nine cells to the right of it so all my data shows up in a viewable format.
I checked lots of posts online but can't put my particular code together. I've built it, with the exception of the merge.
Sub MergeTest()
Dim cel As Range
Dim WS As Worksheet
For Each WS In Worksheets
For Each cel In WS.Range("$A1:$A15")
If InStr(1, cel.Value, "Appt Note:") > 0 Then Range(cel.Offset(1, 9)).Merge
Next
Next
End Sub
As per my comment, hereby a sample of Range.Find where in this case I assume "Appt Note:" only exists once per sheet:
Sub Test()
Dim ws As Worksheet
Dim cl As Range
For Each ws In ThisWorkbook.Worksheets
Set cl = ws.Range("A:A").Find(What:="Appt Note:", Lookat:=xlPart)
If Not cl Is Nothing Then
cl.Offset(0, 1).Resize(1, 9).Merge
End If
Next
End Sub
Note: Merged cells are VBA's worst nightmare! Try to stay away from them. Maybe you can let the text just overflow?
Edit: In case your value could exist multiple times, use Range.FindNext:
Sub Test()
Dim ws As Worksheet
Dim cl As Range
Dim rw As Long
For Each ws In ThisWorkbook.Worksheets
Set cl = ws.Range("A:A").Find(What:="Appt Note:", Lookat:=xlPart)
If Not cl Is Nothing Then
rw = cl.Row
Do
cl.Offset(0, 1).Resize(1, 9).Merge
Set cl = ws.Range("A:A").FindNext(cl)
If cl Is Nothing Then
GoTo DoneFinding
End If
Loop While cl.Row <> rw
End If
DoneFinding:
Next
End Sub
Sub MergeTest()
Dim ws As Worksheet, cell As Range
For Each ws In ThisWorkbook.Worksheets
For Each cell In ws.Range("A1:A15")
If cell.Value Like "Appt Note:*" Then cell.Resize(1, 9).Merge
Next
Next
End Sub
ThisWorkbook refers to the workbook where the VBA code is, to avoid issues when a different workbook is active. The Like operator can be used to check if the cell value matches a wildcard pattern.
cell.Resize(1, 9) can be used to get a new range starting from cell and resized to 9 columns.
I found code that will do what I need. See below. I've tested it and it works. It will start at the bottom of my spreadsheet and find the last row with data and work it's way up until it reaches my first row.
Thanks so much for all your help! If you have any suggestions, advice, warnings, etc regarding the code below, please share. As I said, I am completely new to VB and know just enough to be dangerous. So I can use all the help I can get. :)
Sub mergeCellsBasedOnCriteria()
Dim myFirstRow As Long
Dim myLastRow As Long
Dim myCriteriaColumn As Long
Dim myFirstColumn As Long
Dim myLastColumn As Long
Dim myWorksheet As Worksheet
Dim myCriteria As String
Dim iCounter As Long
myFirstRow = 1
myCriteriaColumn = 1
myFirstColumn = 2
myLastColumn = 10
myCriteria = "Appt Note:"
Set myWorksheet = Worksheets("Sample")
With myWorksheet
myLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For iCounter = myLastRow To myFirstRow Step -1
If .Cells(iCounter, myCriteriaColumn).Value = myCriteria Then
.Range(.Cells(iCounter, myFirstColumn), .Cells(iCounter, myLastColumn)).Merge
.Range(.Cells(iCounter, myFirstColumn), .Cells(iCounter, myLastColumn)).WrapText = True
End If
Next iCounter
End With
End Sub
I'm looking for some VBA that will allow me to loop through several different REGIONS on a worksheet. Not individual cells, necessarily, but to jump from "currentregion" to the next "currentregion". And once the region is located, it should be selected and copied.
I've tried setting a StartCell (via Cells.Find(What:="*") and then using that cell to select the corresponding 'currentregion'. The issue is how to move to the next 'currentregion', until all 'currentregions' on the worksheet have been copied/pasted.
My results are inconsistent so far, where sometimes all the necessary regions are copied/pasted, but other times some of the regions are ignored (same exact worksheet, same exact data).
Set StartCell = Cells.Find(What:="*", _
After:=Cells(Rows.Count, Columns.Count), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)Do
'Select Range and copy it
If StartCell <> "" Then
StartCell.currentregion.CopyPicture
'Select a cell to paste the picture in
Range("A16").PasteSpecial
'Move to next range to be copied
Set StartCell = StartCell.End(xlToRight).End(xlToRight)
StartCell.Select
End If
Loop Until StartCell = ""
Something like that should work
Option Explicit
Public Sub ProcessEachRegion()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define your sheet
Dim StartCell As Range
Set StartCell = ws.Range("A1") 'define start cell
Do Until StartCell.Column = ws.Columns.Count 'loop until end of columns
With StartCell.CurrentRegion
'do all your copy stuff here!
'.Copy
'Destination.Paste
Set StartCell = .Resize(1, 1).Offset(ColumnOffset:=.Columns.Count - 1).End(xlToRight)
End With
Loop
End Sub
It looks for the next region right to the previous one (regions 1 to 5 in the example below).
The main sub (I named it tgr) will call a function named GetAllPopulatedCells which defines a range for all populated cells in a worksheet. The .Areas property will let your loop through each region. It will then copy each Area/Region as a picture (still not sure why you want this) and put it in the destination cell, and then adjust the destination cell as needed so that all of the pasted images are stacked on top of each other.
Sub tgr()
Dim ws As Worksheet
Dim rAllRegions As Range
Dim rRegion As Range
Dim rDest As Range
Set ws = ActiveWorkbook.ActiveSheet
Set rAllRegions = GetAllPopulatedCells(ws)
Set rDest = ws.Range("A16")
If rAllRegions Is Nothing Then
MsgBox "No populated cells found in '" & ws.Name & "'. Exiting Macro.", , "Error"
Exit Sub
End If
For Each rRegion In rAllRegions.Areas
rRegion.CopyPicture
rDest.PasteSpecial
Set rDest = rDest.Offset(rRegion.Rows.Count)
Next rRegion
End Sub
Public Function GetAllPopulatedCells(Optional ByRef arg_ws As Worksheet) As Range
Dim ws As Worksheet
Dim rConstants As Range
Dim rFormulas As Range
If arg_ws Is Nothing Then Set ws = ActiveWorkbook.ActiveSheet Else Set ws = arg_ws
On Error Resume Next
Set rConstants = ws.Cells.SpecialCells(xlCellTypeConstants)
Set rFormulas = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
Select Case Abs(rConstants Is Nothing) + 2 * Abs(rFormulas Is Nothing)
Case 0: Set GetAllPopulatedCells = Union(rConstants, rFormulas)
Case 1: Set GetAllPopulatedCells = rFormulas
Case 2: Set GetAllPopulatedCells = rConstants
Case 3: Set GetAllPopulatedCells = Nothing
End Select
Set ws = Nothing
Set rConstants = Nothing
Set rFormulas = Nothing
End Function
Trying to put together a macro that searches each row to see if it contains 7 search terms (see "Warranty:" example below). If the cell starts with one of the phrases (like "Warranty:"), then that cell is pasted in a specific cell (same row but different column) in another worksheet.
Issues:
Had trouble with the macro until I added the select function - I know this slows them down, but I couldn't figure out a way to do this without it
Can't figure out how to get it to loop through all rows
Errors if the row doesn't have the word - need it to just keep going through
Sub FindTest()
Worksheets("Macro").Range("1:1").Find(What:="Warranty: ", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True).Copy
'Cell begins with "Warranty:" but text following varies
Sheets("CSV Upload").Select
Sheets("CSV Upload").Range("J1").Select
ActiveSheet.Paste
End Sub
UPDATE:
Sub FindTest()
Dim Macro As Worksheet: Set Macro = Sheets("Macro")
Dim CSV As Worksheet: Set CSV = Sheets("CSV Upload")
'On Error Resume Next
For R = 1 To Macro.UsedRange.Rows.Count
Set rng = Macro.Rows(R)
Dim FindRange As Range: Set FindRange = rng.Find(What:="Warranty:", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
'FindRange.Copy CSV.Range("J1")
'CSV.Cells(1, J) = Macro.Cells(FindRange)
Next
'On Error GoTo 0
End Sub
To loop through each row in the worksheet:
Dim ws As Worksheet: Set ws = Sheets("Macro")
Dim csv_upload As workseet: Set csv_upload = Sheets("CSV Upload")
For r = 1 To ws.UsedRange.Rows.Count
Set rng = ws.Rows(r)
rng.Find(What:="Warranty: ", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
...
Next
Then to copy the values, depending on which cells you need to copy
csv_upload.cells(dest_row, dest_col) = ws.cells(orig_row, orig_col)
For it to continue when you have an error, you can tell it to resume
On Error Resume Next
' potential for error to be raised
' Don't use this unless you know you are going to get a specific
' error and know there are no unintended consequences of ignoring it.
On Error GoTo 0
Using the code in your update, the following code should work for you.
Sub FindWarranty()
Dim Macro As Worksheet: Set Macro = Sheets("Macro")
Dim CSV As Worksheet: Set CSV = Sheets("CSV Upload")
Dim rng As Range, FindRange As Range
Dim Phrase As String
Phrase = "Warranty:"
For r = 1 To Macro.UsedRange.Rows.Count
Set rng = Macro.Rows(r)
Set FindRange = rng.Find(What:=Phrase, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
If Not FindRange Is Nothing Then
' Set destination cell to what you need it to be
c = 1
CSV.Cells(r, c) = FindRange
End If
Next
End Sub
A slightly more elegant way that Quicksilver alluded to is:
Sub FindWarrantys()
Dim Macro As Worksheet: Set Macro = Sheets("Macro")
Dim CSV As Worksheet: Set CSV = Sheets("CSV Upload")
Dim FoundCell As Range, FirstAddr As String
Dim Phrase As String, c As Integer
Phrase = "Warranty:"
' Find the first occurrence. The after variable is set to the
' last cell so that it will start searching from the beginning.
Set FoundCell = Macro.UsedRange.Find(what:=Phrase, _
after:=Macro.UsedRange.Cells(Macro.UsedRange.Cells.Count))
' Save the address of the first occurrence to prevent an infinite loop
If Not FoundCell Is Nothing Then
FirstAddr = FoundCell.Address
End If
' Loop through all finds
Do Until FoundCell Is Nothing
c = 1 ' Adjust for logic to determine which column
CSV.Cells(FoundCell.Row, c) = FoundCell
' Find the next occurrence
Set FoundCell = Macro.UsedRange.FindNext(after:=FoundCell)
' Break if we're back at the first address
If FoundCell.Address = FirstAddr Then
Exit Do
End If
Loop
End Sub
I am trying to do the following. I have several spreadsheets that are named something like "ITT_198763" where the ITT part stays the same but the number changes. I also have one tab called program where the 6 digit number is imported on row 40 (hence the RngToSearch below). I need the program to 1) find the "ITT" sheet for a certain 6 digit number, 2) identify the corresponding row in the "Program" tab, and copy information from the "ITT" tab to row 41 of the identified column. I will be copying more information from the ITT sheet to the specified column, but for now I am just trying to get it to work once.
From the MsgBox, I know it identifies the correct prjNumber (the 6 digit number), but I get the runtime 1004 error on the line Set RngDest. Any help will be appreciated!
Sub Summary_Table()
Dim wks As Worksheet
Dim RngToSearch As Range, RngDest As Range
Dim foundColumn As Variant
Dim prjNumber
For Each wks In ActiveWorkbook.Worksheets
If ((Left(wks.Name, 3) = "ITT")) Then
prjNumber = Right(wks.Name, 6)
MsgBox (prjNumber)
Set RngToSearch = Sheets("Program").Range("C40:q40")
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch, False)
With Sheets("Program")
Set RngDest = .Range(1, foundColumn) 'Project Name
End With
If Not IsError(foundColumn) Then
wks.Range("E2").Copy RngDest
End If
End If
Next wks
End Sub
I tried the .cell instead with the following code (all else is the same) and now get runtime error 13 on the Set RngDest line:
Set RngToSearch = Sheets("Program").Range("C40:q48")
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch.Rows(1), False)
With Sheets("Program")
Set RngDest = RngToSearch.Cells(1, foundColumn) 'Project Name
End With
Yuo are getting that error because foundColumn has an invalid value. Step through the code and see what is the value of foundColumn
Here is an example which works.
Sub Sample()
Dim RngDest As Range, RngToSearch As Range
foundColumn = 1
Set RngToSearch = Sheets("Program").Range("C40:q40")
Set RngDest = RngToSearch.Cells(1, foundColumn)
Debug.Print RngDest.Address
End Sub
Add MsgBox foundColumn before the line Set RngDest = RngToSearch.Cells(1, foundColumn) and see what value do you get. I guess the line
foundColumn = Sheets("Program").Application.Match(prjNumber, RngToSearch, False)
is not giving you the desired value. Here is the way to reproduce the error.
EDIT (Solution)
You need to handle the situation when no match is found. Try something like this
Sub Sample()
Dim RngDest As Range, RngToSearch As Range
Set RngToSearch = Sheets("Program").Range("C40:q40")
foundcolumn = Sheets("Program").Application.Match(1, RngToSearch, False)
If CVErr(foundcolumn) = CVErr(2042) Then
MsgBox "Match Not Found"
Else
Set RngDest = RngToSearch.Cells(1, foundcolumn)
'
'~~> Rest of the code
'
End If
End Sub
You are looking for the Cells function, which has the prototype .Cells([RowIndex], [ColumnIndex]). The Range function takes either a string with a range name (like "A1", or a named range), or other range references.
I figured it out! Found column was the problem. Combining that with the help from the other commenters, the following works:
Sub Summary_Table()
Dim wks As Worksheet
Dim RngToSearch As Range, RngDest As Range
Dim foundColumn As Variant
Dim prjNumber
For Each wks In ActiveWorkbook.Worksheets
If ((Left(wks.Name, 3) = "ITT")) Then
prjNumber = Right(wks.Name, 6)
MsgBox (prjNumber)
Set RngToSearch = Sheets("Program").Range("a40:q48")
foundColumn = Sheets("Program").Rows(40).Find(what:=prjNumber, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False).Column
MsgBox (foundColumn)
With Sheets("Program")
Set RngDest = RngToSearch.Cells(2, foundColumn) 'Project Name
Debug.Print RngDest.Address
End With
If Not IsError(foundColumn) Then
wks.Range("E3").Copy RngDest
End If
End If
Next wks
End Sub
https://dl.dropbox.com/u/3327208/Excel/copydown.xlsx
This is the sheet if you can't view dropbox.
This is the workbook. What I'm looking to do is where it shows 3M, copy the title of the company down to where it shows Total in Column A, and do the same with the next company.
How do I do this in Excel VBA? I know I can use the last row, but it's not exactly the best way for this I believe, because the original version will have over 300 different companies.
Here is the original code I am using for now. Without the extra bits added in.
Option Explicit
Sub Import()
Dim lastrow As Long
Dim wsIMP As Worksheet 'Import
Dim wsTOT As Worksheet 'Total
Dim wsSHI As Worksheet 'Shipped
Dim wsEST As Worksheet 'Estimate
Dim wsISS As Worksheet 'Issued
Dim Shift As Range
Set wsIMP = Sheets("Import")
Set wsTOT = Sheets("Total")
Set wsSHI = Sheets("Shipped")
Set wsEST = Sheets("Estimate")
Set wsISS = Sheets("Issued")
With wsIMP
wsIMP.Range("E6").Cut wsIMP.Range("E5")
wsIMP.Range("B7:G7").Delete xlShiftUp
End Sub
Matt, I had a great function for this a few months back, but I forgot to copy into my library. However, I've done a pretty good mock-up of what I had before. (I was using it to fill down entries in a pivot table for some reason or other).
Anyway, here it is. You may need to tweak it to meet your exact needs, and I am not claiming it's not prone to any errors at the moment, but it should be a great start.
EDIT = I've updated my code post to integrate into yours to make it easier for you.
Sub Import()
Dim lastrow As Long
Dim wsIMP As Worksheet, wsTOT As Worksheet 'Total
Dim wsSHI As Worksheet, wsEST As Worksheet 'Estimate
Dim wsISS As Worksheet, Shift As Range
Set wsIMP = Sheets("Import")
Set wsTOT = Sheets("Total")
Set wsSHI = Sheets("Shipped")
Set wsEST = Sheets("Estimate")
Set wsISS = Sheets("Issued")
With wsIMP
.Range("E6").Cut .Range("E5")
.Range("B7:G7").Delete xlShiftUp
Call FillDown(.Range("A1"), "B")
'-> more code here
End With
End Sub
Sub FillDown(begRng As Range, col As String)
Dim rowLast As Long, rngStart As Range, rngEnd As Range
rowLast = Range(col & Rows.Count).End(xlUp).Row
Set rngStart = begRng
Do
If rngStart.End(xlDown).Row < rowLast Then
Set rngEnd = rngStart.End(xlDown).Offset(-1)
Else
Set rngEnd = Cells(rowLast, rngStart.Column)
End If
Range(rngStart, rngEnd).FillDown
Set rngStart = rngStart.End(xlDown)
Loop Until rngStart.Row = rowLast
End Sub
enter code here
As long as there are no formulas you don't want to overwrite...
EDIT - updated to set original range based off end of column B
Sub Macro1()
Dim sht as WorkSheet
Set sht = ActiveSheet
With sht.Range(sht.Range("A7"), _
sht.Cells(Rows.Count, 2).End(xlUp).Offset(0, -1))
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub