I am trying to add new data to excel sheet via UserForm but it's doesn't write continuously. just replace value of range E2 and its rows.
Note:If data already exist then update its relevant columns or write
new data to next empty row.
my code is below.
Option Explicit
Private Sub cmdAdd_Click()
Dim FindValue As String, Rng As Range
Dim iRow As Long, ws2 As Worksheet
Set ws2 = Worksheets("ITEM NAMES")
iRow = ws2.Cells(Rows.Count, 2).End(xlUp).Row + 1
FindValue = TextItemName
If Trim(FindValue) <> "" Then
With ws2.Range("E:E")
Set Rng = .Find(What:=FindValue, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Rng.Offset(0, 1) = TextHSNCode.Value
Else
ws2.Cells(iRow, 5).Value = TextItemName.Value
ws2.Cells(iRow, 6).Value = TextHSNCode.Value
End If
End With
End If
End Sub
Related
I want to loop or find multiple value in another sheets. My code doesn't work even after I do..loop the code.
For i = 1 To lastrowBAU
Worksheets(fname).Range("A1:A" & lastrowsheet).Select
Do Until Cell Is Nothing
Set Cell = Selection.find(What:=ThisWorkbook.Worksheets("BAU").Range("A" & i).Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False)
If Not Cell Is Nothing Then
Cell.Activate
ActiveCell.Copy
ActiveCell.Insert Shift:=xlShiftDown
ActiveCell.Offset(1, 0).Select
Selection.Replace What:=ThisWorkbook.Worksheets("BAU").Range("A" & i).Value, _
replacement:=ThisWorkbook.Worksheets("BAU").Range("B" & i).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Set Cell = Worksheets(fname).Range("A1:A" & lastrowsheet).FindNext(Cell)
End If
Loop
Next i
You need to set the cell before entering the loop
Set cell = rngSrc.Find(sA, LookIn:=xlFormulas, LookAt:=xlPart, _
After:=rngSrc.Cells(rngSrc.Cells.Count), SearchOrder:=xlByRows, MatchCase:=False)
If Not cell Is Nothing Then
however you also need to avoid an endless loop by checking if the search has returned to the first one found.
Option Explicit
Sub macro1()
Dim ws As Worksheet, wsBAU As Worksheet
Dim cell As Range, rngSrc As Range
Dim fname As String, lastrow As Long, lastrowBAU As Long
Dim i As Long, n As Long, first As String
Dim sA As String, sB As String
fname = "Sheet1"
With ThisWorkbook
Set ws = .Sheets(fname)
Set wsBAU = .Sheets("BAU")
End With
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngSrc = .Range("A1:A" & lastrow)
End With
With wsBAU
lastrowBAU = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngSrc = .Range("A1:A" & lastrow)
End With
' search and replace
Application.ScreenUpdating = False
For i = 1 To lastrowBAU
sA = wsBAU.Cells(i, "A")
sB = wsBAU.Cells(i, "B")
Set cell = rngSrc.Find(sA, LookIn:=xlFormulas, LookAt:=xlPart, _
After:=rngSrc.Cells(rngSrc.Cells.Count), SearchOrder:=xlByRows, MatchCase:=False)
If Not cell Is Nothing Then
first = cell.Address
Do
' insert cell above
cell.Insert xlDown
cell.Offset(-1).Value2 = cell.Value2
cell.Value2 = Replace(cell.Value2, sA, sB)
' expand search range
n = n + 1
Set rngSrc = ws.Range("A1:A" & lastrow + n)
' find next
Set cell = rngSrc.FindNext(cell)
Loop While cell.Address <> first
End If
Next
Application.ScreenUpdating = True
MsgBox n & " replacements", vbInformation
End Sub
I am trying to select a range until the last used row in the sheet. I currently have the following:
Sub Select_Active_Down()
Dim lr As Long
lr = ActiveSheet.UsedRange.Rows.Count
If Cells(ActiveCell.Row, ActiveCell.Column) = Cells(lr, ActiveCell.Column) Then
MsgBox "There isn't any data to select."
Else
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(lr, ActiveCell.Column)).Select
Cells(lr, ActiveCell.Column).Activate
End If
End Sub
The issue is that I need to select multiple columns, and this will only select the first column of the active range. How can I modify this to select multiple columns rather than just the first?
What about selection the entire region? This can be done as follows in VBA:
Selection.CurrentRegion.Select
There also is the possibility to select the entire array. For that, just press Ctrl+G, choose Special and see over there.
I would do this slightly different. I would use .Find to find the last row and the last column (using the same logic shown in the link) to construct my range rather than using Selection | Select | ActiveCell | UsedRange | ActiveSheet.
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim rng As Range
'~~> Change it to the relevant sheet
Set ws = Sheet1
With ws
'~~> Check if there is data
If Application.WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "No Data Found"
Exit Sub
End If
'~~> Find last row
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find last column
LastColumn = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Construct your range
Set rng = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
'~~> Work with the range
With rng
MsgBox .Address
'
'~~> Do what you want with the range here
'
End With
End With
End Sub
I am trying to add a blank row if the cell values under column C is "Confirm". Is this possible?
I want the macro to add blank rows below until the last active row of the sheet if it finds "Confirm" under column C.
regards,
Arjun T A
Option Explicit
Sub blankAfterConfirm()
Dim rng As Range, fnd As Range, addr As String
With Worksheets("sheet3").Range("C:C")
Set rng = .Find(what:="confirm", After:=.Cells(1), MatchCase:=False, _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, SearchFormat:=False)
If Not rng Is Nothing Then
addr = rng.Address(0, 0)
Set fnd = rng
Do
Set fnd = Union(fnd, rng)
Set rng = .FindNext(After:=rng)
Loop Until addr = rng.Address(0, 0)
fnd.Offset(1, 0).EntireRow.Insert
End If
End With
End Sub
Edited.
Dim x As Long, lRow As Long
lRow = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
For x = lRow To 2 Step -1
If Cells(x, 3).Value = "Confirm" Then
With Cells(x, 3).Offset(1).EntireRow
.Insert Shift:=xlDown
.ClearFormats
End With
End If
Next x
Good day to everyone,
I have been trying to find an answer here that would fit my problem but I have been unsuccessful. I am using FIND to search column F for cell with #N/A value and copy adjacent cells to another "Sheet2" at the end of the column A. I have made the following code that works but my problem is I want to make it to loop to find the next cell with #N/A value till find all.
Sub Find()
Dim SerchRange As Range
Dim FindCell As Range
Set SerchRange = Range("F:F")
Set FindCell = SerchRange.FIND(What:="#N/A", _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If FindCell Is Nothing Then
MsgBox "Nothing was found all clear"
Else
FindCell.Select
ActiveCell.Offset(0, -3).Resize(, 3).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
End Sub
Try this and let me know if it works:
Option Explicit
Sub Find()
Application.ScreenUpdating = False
Dim SearchRange As Range
Dim FindCell As Range
Dim Check As Boolean
Dim LastRow As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim FindCounter As Long
Set ws = ThisWorkbook.Worksheets("Sheet1") ' <--- Insert the name of your worksheet here
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
LastRow = ws.Cells(Rows.Count, "F").End(xlUp).Row ' <--- Finds the last used row
Set SearchRange = Range("F1:F" & LastRow)
FindCounter = 0
For Each FindCell In SearchRange
If FindCell.Value = "#N/A" Then
FindCounter = FindCounter + 1
FindCell.Offset(0, -3).Resize(, 3).Copy
ws2.Range("A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If
Next
MsgBox "Succes!" & vbNewLine & vbNewLine & "This many cells were found: " & FindCounter
Application.ScreenUpdating = True
End Sub
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 4 years ago.
Improve this question
I want to make a macro via an if then else function (maybe make use of a loop).
I have two separate files, named "orderregistratie" + "werkorder template".
I want to search in column A of sheets("datablad") in orderregistratie for the value sheets("export datablad").Range("A2") that is in werkorder template.
If this value exists in column A then copy the row of A2 from export datablad and paste it in the row where the value is found.
If it doesn't already exist I want to insert a new row at A2 in orderregistratie and copy the row of A2 from export datablad in the new row.
My VBA knowledge is not really good and I can't write the macro by myself. Is there anyone who can help me write it?
Give this a try. I'll adjust as needed. Just be double check if both workbooks are saved to your desktop.
Option Explicit
Private wkbOrderReg As Workbook, _
wkbOrderWork As Workbook, _
wkb As Workbook
Private wsOBJ As Worksheet, _
ws As Worksheet
Private rngSearch As Range, _
rngRow As Range, _
rng As Range, _
r As Range
Private strSearch As String
Public Sub DarudeSandStorm()
Dim LastRow As Long, _
LastColumn As Long
Dim arr As Variant
With Application.Workbooks
Set wkbOrderReg = .Open(Filename:=strVar("orderregistratie.xlsx"))
Set wkbOrderWork = .Open(Filename:=strVar("werkorder template.xlsx"))
End With
With wkbOrderWork
For Each ws In .Worksheets
Set wsOBJ = ws
If UCase$(wsOBJ.Name) = UCase$("export datablad") Then
With wsOBJ
Set rng = .Range(.Cells(2, 1), .Cells(2, 1))
strSearch = rng.Value
LastColumn = getLAST_COLUMN(wsOBJ)
Set rngRow = .Range(.Cells(2, 1), .Cells(2, LastColumn))
End With
arr = rngRow
Exit For
End If
Next ws
End With
With wkbOrderReg
For Each ws In .Worksheets
Set wsOBJ = ws
If UCase$(wsOBJ.Name) = UCase$("export datablad") Then
With wsOBJ
LastRow = getLAST_ROW(wsOBJ)
Set rngSearch = .Range(.Cells(1, 1), .Cells(LastRow, 1))
End With
For Each r In rngSearch
If UCase$(r.Value) = UCase$(strSearch) Then
r = arr
End If
Next r
End If
Next ws
End With
With Application
For Each wkb In .Workbooks
If Not wkb = .ThisWorkbook Then
With .Workbooks(wkb.Name)
.Save
.Close
End With
End If
Next wkb
End With
End Sub
Private Function getLAST_COLUMN(objWS As Worksheet) As Long
Dim wsDES As Worksheet, _
wkbSUB As Workbook, _
rngCHECK As Range
Set rngCHECK = objWS.Cells.Find(What:="*", _
After:=Range("A1"), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not rngCHECK Is Nothing Then
getLAST_COLUMN = objWS.Cells.Find("*", _
Range("A1"), _
xlFormulas, _
, _
xlByColumns, _
xlPrevious).Column
Else
getLAST_COLUMN = 1
End If
End Function
Private Function getLAST_ROW(objWS As Worksheet) As Long
Dim wsDES As Worksheet, _
wkbSUB As Workbook, _
rngCHECK As Range
Set rngCHECK = objWS.Cells.Find(What:="*", _
After:=Range("A1"), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not rngCHECK Is Nothing Then
getLAST_ROW = objWS.Cells.Find("*", _
Range("A1"), _
xlFormulas, _
, _
xlByRows, _
xlPrevious).Row
Else
getLAST_ROW = 1
End If
End Function
Private Function strVar(ByRef str As String) As String
strVar = Environ("Userprofile") & "\Desktop\" & str
End Function
#Mischa Urlings for this example i have save both workbooks ("orderregistratie" + "werkorder template") on my desktop so you must change their path on the code.
Option Explicit
Sub test()
Dim WbO As Workbook
Dim WbW As Workbook
Dim i As Long
Dim LRA As Long
Dim RowToCopy As Long
Dim Rowstr As Long
Dim Searchstr As String
Dim Address As Range
Dim Searchrng As Range
Workbooks.Open Filename:="C:\Users\xxxx\Desktop\" & "orderregistratie.xlsx" '<= Open Workbooks (for this example files are stored on desktop
Workbooks.Open Filename:="C:\Users\xxxx\Desktop\" & "werkorder template.xlsx"
Set WbO = Workbooks("orderregistratie.xlsx") '<= Set workbook to variables
Set WbW = Workbooks("werkorder template.xlsx")
LRA = WbW.Worksheets("export datablad").Range("A" & Rows.Count).End(xlUp).Row '<= Find Lastrow
For i = 2 To LRA '<= Loop column A (Workbook:werkorder template)
Searchstr = WbW.Worksheets("export datablad").Range("A" & i).Value '<= Set what to search for
Rowstr = i '<= Searchstr row
Set Searchrng = WbO.Worksheets("datablad").Columns("A") '<= Set where to search for
Set Address = Searchrng.Find(What:=Searchstr, LookAt:=xlWhole) '<= Result of the search
If Address Is Nothing Then
'If what we search for not found
WbO.Worksheets("datablad").Rows("2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
WbW.Worksheets("export datablad").Rows(Rowstr).EntireRow.Copy
WbO.Worksheets("datablad").Rows(2).PasteSpecial Paste:=xlPasteValues
Else
'If what we search for found
RowToCopy = Address.Row '<= Where we find the Searchstr
WbW.Worksheets("export datablad").Rows(i).EntireRow.Copy
WbO.Worksheets("datablad").Rows(RowToCopy).PasteSpecial Paste:=xlPasteValues
End If
Next i
With WbO
.Save
.Close '<= Close open workbooks
End with
With WbW
.Save
.Close '<= Close open workbooks
End with
End Sub