I have data contained in "Sheet1" with only 2 columns. Column "A" and Column "B".
Below are my questions
The below code which is working fine, but at the moment, I have to put every single word within the cell to bring up a result. Is there a way there, where I can type only a word or a few words contained within that cell that it will bring up a result.
Is there a way, if I have 2 different results pulled from the data, like duplicates, what is the code to see the next. Do I need a command button like eg: Next
Private Sub CommandButton1_Click()
Dim rng As Range
Dim cl As Range
Dim vFind
Dim R As Long
Set rng = Sheet1.Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
vFind = Me.TextBox1.Text
With rng
Set cl = .Find(vFind, LookIn:=xlValues)
If Not cl Is Nothing Then R = cl.Row
Me.TextBox2.Value = Cells(R, 2).Value
End With
Related
I would like to prepare a tool which searches for anything in certain column, and if see anything, copy this value and paste this in few elements on its row
For example if in G2 there is value "ADD", then A2+B2 + E2 + F2 would be an "ADD" to (except C)
Its very hard for me to overcome obstacles, so far I came up with that.. I know this code is hard to bear with but I rarely use VBA so i never had a chance to learn so its mix of what I've found here on stackoverflow combined as per my requirements
Dim wb as Workbook
Dim ws As Worksheet
wb = ActiveWorkbook.Name
ws = Application.ActiveSheet
With ws
Set myRange = Range("G1", Range("G1").End(xlDown))
For i = 1 to myRange
if i <>"" Then
Range("A1", Range("A1").End(xlToRight)).Select
Range("A1", Range("A1").End(xlToRight)).Value = i.text
[I know this part will do from the first element of A to the last but I dont know how to choose elements I wish if they're not one next to each other]
Next i
End with
For what you want to do, it seem you don't need to declare "wb" and "ws". Vba default will use the ActiveSheet. Also wb is declared to be workbook, but ActiveWorkbook.Name is acutally an text. Your code will encounter error.
If you want to loop from G1 to its last inputted cell, you can refer to following code:
For i = 1 To Cells(Rows.Count,7).End(xlUp).Row
The rows.count refer to the last row (1048576) in excel. and "end(xlup)" will find the last cell which inputted value at G column. And the ".row" return the row number of the last cell.
Similarly, you can use "Cells(1, Columns.Count).End(xlToLeft)" to find the last column's cell inputted at row 1
You may try below code:
For i = 1 To Cells(Rows.Count, 7).End(xlUp).Row
If Cells(i, 7).Value <> "" Then
Range(Cells(i, 1), Cells(i, 2)).Value = Cells(i, 7).Value
Range(Cells(i, 4), Cells(i, Columns.Count).End(xlToLeft)).Value = Cells(i, 7).Value
End If
Next i
However, You mention you want to copy except C column. Since I dont know what actual condition that you will not copy to the column. I just simply separate the code into 2 parts, one for A and B column, another one for D to the last columns
One option could be the following:
Sub FindAndCopy()
Dim ws As Worksheet, searchRng As Range, cl As Range, searchTerm As Variant
Set ws = ThisWorkbook.ActiveSheet
With ws
Set searchRng = .Range("G1", .Range("G1").End(xlDown))
searchTerm = "ADD"
For Each cl In searchRng
If cl = searchTerm Then
Range("A" & cl.Row) = searchTerm
Range("B" & cl.Row) = searchTerm
Range("E" & cl.Row) = searchTerm
Range("F" & cl.Row) = searchTerm
End If
Next cl
End With
End Sub
Data is transferred from a web-form to Excel. Not every cell receives inputs. There are many cells, it is time consuming to scan each cell looking for text.
How do I get the text automatically copied from sheet1 to sheet2. But I don't want the cells displayed in the same layout as the original sheet. I would like them to be grouped together, eliminating all of the empty cells in between. I would also like to grab the title from the row that contains the text.
I found this macro:
Sub CopyC()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("C1:C10")
For Each cel In SrchRng
If cel.Value <> "" Then
cel.Offset(2, 1).Value = cel.Value
End If
Next cel
It grabs only cells that contain text, but it displays it in the exact same layout that it found it in. Any help would be appreciated and save me a lot of scan time in the future, thanks in advance :)
I guess this is what you are looking for:
Sub CopyNonBlankCells()
Dim cel As Range, myRange As Range, CopyRange As Range
Set myRange = Sheet1.Range("C1:C20") '---> give your range here
For Each cel In myRange
If Not IsEmpty(cel) Then
If CopyRange Is Nothing Then
Set CopyRange = cel
Else
Set CopyRange = Union(CopyRange, cel)
End If
End If
Next cel
CopyRange.Copy Sheet2.Range("C1") '---> enter desired range to paste copied range without blank cells
End Sub
Above code will copy range C1:C20 in Sheet1 to C1 in Sheet2
Got this from here.
EDIT: Following answer is based on your comment
________________________________________________________________________________
If you'll write something like below
Set myRange = Sheet1.Range("G:G")
Set myRange = Sheet2.Range("G:G")
myRange will be first set to Sheet1.Range("G:G") and then to Sheet2.Range("G:G") that means current range that myRange will have is Sheet2.Range("G:G").
If you want to use multiple ranges you can go for UNION function but there's a limitation that using UNION, you can combine different ranges but of only one sheet. And your requirement is to combine ranges from different sheets. To accomplish that I am adding a new worksheet and adding your G:G ranges from all the sheets to it. Then after using newly added sheet I am deleting it.
Following code will give you the desired output in the sheet named Result.
Sub CopyNonBlankCells()
Dim cel As Range, myRange As Range, CopyRange As Range
Dim wsCount As Integer, i As Integer
Dim lastRow As Long, lastRowTemp As Long
Dim tempSheet As Worksheet
wsCount = Worksheets.Count '--->wsCount will give the number of Sheets in your workbook
Set tempSheet = Worksheets.Add '--->new sheet added
tempSheet.Move After:=Worksheets(wsCount + 1)
For i = 1 To wsCount
If Sheets(i).Name <> "Result" Then '---> not considering sheet "Result" for taking data
lastRow = Sheets(i).Cells(Rows.Count, "G").End(xlUp).Row '--->will give last row in sheet
lastRowTemp = tempSheet.Cells(Rows.Count, "G").End(xlUp).Row '--->will give last row in newly added sheet
Sheets(i).Range("G1:G" & lastRow).Copy _
tempSheet.Range("G" & lastRowTemp + 1).End(xlUp)(2)
End If
Next i
lastRowTemp = tempSheet.Cells(Rows.Count, "G").End(xlUp).Row
Set myRange = tempSheet.Range("G1:G" & lastRowTemp) '--->setting range for removing blanks cells
For Each cel In myRange
If Not IsEmpty(cel) Then
If CopyRange Is Nothing Then
Set CopyRange = cel
Else
Set CopyRange = Union(CopyRange, cel)
End If
End If
Next cel
CopyRange.Copy Sheets("Result").Range("G1") '---> enter desired range to paste copied range without blank cells
Application.DisplayAlerts = False
tempSheet.Delete '--->deleting added sheet
Application.DisplayAlerts = True
End Sub
You can use arrays!
Instead of copying information from one cell to another, you can store all your information in an array first, then print the array on another sheet. You can tell the array to avoid empty cells. Typically, using arrays is the best way to store information. (Often the fastest way to work with info)
If you are only looking at one column, you could use a one-dimensional array. If you are looking at multiple columns, and want to print the information into the corresponding column (but different cells) in another page then you could a multi-dimensional array to store column number/anything else you wanted.
From your code, it could look like this:
Sub CopyC()
Dim SrchRng As Range, cel As Range
'Declare your 1-d array (I don't know what you are storing)
Dim myarray() as variant
Dim n as integer
Dim i as integer
Set SrchRng = Range("C1:C10")
'define the number of elements in the array - 1 for now, increase it as we go
n = 0
Redim myarray(0 to n)
For Each cel In SrchRng
If cel.Value <> "" Then
'redim preserve stores the previous values in the array as you redimension it
Redim Preserve myarray(0 to n)
myarray(n) = cel.Value
'increase n by 1 so next time the array will be 1 larger
n = n + 1
End If
Next cel
'information is now stored, print it out in a loop
'this will print it out in sheet 2 providing it is called "Sheet2"
For i = 0 to ubound(myarray)
Sheets("Sheet2").cells(i,1).value = myarray(i)
Next i
For a project I am working on, I am attempting to copy a row from an excel spreadsheet, only if the correct criteria are met.
For example,
I need to copy a row that has the following items in them:
Fruit, Apple, True, Cell<4
I've tried using something like
Sub Database_RoundedRectangle1_Click()
Dim c As Range, i As Long
Dim SrchRng, strSearch
Set SrchRng = ActiveSheet.Range("A4:T60", ActiveSheet.Range("A60:T60").End(xlUp))
For Each strSearch In Array("Apple")
Set c = SrchRng.Find(strSearch, LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Copy
Sheets("Results").Paste
Next strSearch
End Sub
But the problem with this is that it only searches for a single criteria: Apple. I need the script to scan the whole row for all filters to be correct, then copy the row.
The script I used also only copies the row once, and does not seem to copy all rows that include Apple.
I am assuming that your data is consistent i.e. you are looking for Fruit in one column, Apple in another column and likewise for TRUE and <4.
Here in the code I am looking for Fruit in Column A, Apple in Column B, TRUE in Column C and <4 in Column D. You can change column numbers as required.
I've named the sheet where data is as Data and the sheet to paste copied rows as Results
Sub CopyRow()
Dim LastRowCurr As Long, LastRowResult As Long
Dim LastColumn As Long
Dim i As Long
Dim currWS As Worksheet, resultWS As Worksheet
Dim MyRange As Range
Set currWS = ThisWorkbook.Sheets("Data") '---> sheet where data is
Set resultWS = ThisWorkbook.Sheets("Results") '---> sheet to paste copied rows
lastRow = currWS.Cells(Rows.Count, "A").End(xlUp).Row
LastRowResult = resultWS.Cells(Rows.Count, "A").End(xlUp).Row
With currWS
For i = 4 To lastRow
'change column numbers in the below line as required
If .Cells(i, 1).Value = "Fruit" And .Cells(i, 2).Value = "Apple" And .Cells(i, 3).Value = True And .Cells(i, 4).Value < 4 Then
.Rows(i).Copy Destination:=resultWS.Range("A" & LastRowResult)
LastRowResult = LastRowResult + 1
End If
Next i
End With
End Sub
I guess this is what you want.
you have to add another loop for the .find function. On your Code it only looks once for Apples. What you have to do is, you have to add another loop and repeat the .find function until you this .find function gives your the first match again . Try something like this:
Sub Database_RoundedRectangle1_Click()
Dim c As Range, i As Long
Dim SrchRng, strSearch
Dim wsResults As Worksheet
Dim firstAddress
Set SrchRng = ActiveSheet.Range("A1:T60", ActiveSheet.Range("A60:T60").End(xlUp))
Set wsResults = ThisWorkbook.Worksheets("Results")
For Each strSearch In Array("Apple")
Set c = SrchRng.Find(strSearch, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.EntireRow.Copy wsResults.UsedRange.Cells(wsResults.UsedRange.Rows.Count + 1, 1)
Set c = SrchRng.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next strSearch
End Sub
I'm fairly new to VBA and I'm having a lot of trouble doing a seemingly easy task. I've tried many different codes using this website and this is the one that gets me closest to what I want but it doesn't return any values. Here is the premise of what I need it to do:
1) Search the entire first row of columns (A1 to let's say Z1) of a worksheet for specific text such "Closed"
2) If the desired text "Closed" is found in one of the columns, copy all the values from that column
3) Paste those values from the column into Column J of another worksheet ("Source_Workbook")
****EDIT**: I want the column data to paste starting at the next empty row after row 5 of column J (10). I was having trouble using "Offset" in this case. Also, I want only the values to be pasted (keep the formatting of the page onto which the data is being pasted).
My problem is that this code keeps giving me errors when I try to do "Range.PasteSpecial." I hope I have the right approach. Please let me know if I can clarify anything further.
Dim rng As Range
Dim cl As Object
Dim strMatch As String
strMatch = "Closed" 'Search first row for columns with "Closed"
Set rng = Target_Workbook2.Sheets(2).Range("A1:Z1")
For Each cl In rng
If cl.Value = strMatch Then
cl.EntireColumn.Copy
Exit For
With Source_Workbook2.Sheets(2)
Sheets(2).Columns("J").Offset(5, 0).PasteSpecial xlPasteValues
End With
End If
Next cl
Would
Target_Workbook2.Sheets(2).Range("A1:Z1").AutoFilter 1, "*Closed*"
possibly work better for filtering?
You are exiting for loop before pasting the values on Sheet2.
Try this code:
Dim rng As Range
Dim cl As Object
Dim strMatch As String
strMatch = "Closed" 'Search first row for columns with "Closed"
Set rng = Target_Workbook2.Sheets(2).Range("A1:Z1")
For Each cl In rng
If cl.Value = strMatch Then
cl.EntireColumn.Copy Destination:=Sheets("Sheet2").Columns(10)
Exit For
End If
Next cl
Edit 1: Based on the comment
This will copy the column and paste it from row 5 on Sheet2.
Dim rng As range
Dim cl As Object
Dim strMatch As String
Dim lastrow As Long
Dim sh2lastrow As Long '<-- Newly added
Dim col As Long '<-- Newly added
Dim range As range '<-- Newly added
strMatch = "Closed" 'Search first row for columns with "Closed"
lastrow = Sheets("Sheet1").range("A65536").End(xlUp).Row ' or + 1
sh2lastrow = Sheets("Sheet2").range("J65536").End(xlUp).Row + 4 '<-- Newly added (Because you want to start from row 5)
Set rng = Sheets("Sheet1").range("A1:Z1")
For Each cl In rng
If cl.Value = strMatch Then
lastrow = Cells.CurrentRegion.Rows.Count '<-- (Getting row count of given column)
col = cl.Column '<-- (Getting column number of given column)
With Sheets("Sheet1")
Set range = .range(.Cells(2, col), .Cells(lastrow, col)) '<-- (Setting up the range to copy)
End With
range.Copy
Sheets("Sheet2").Activate '<-- Newly added
Sheets("Sheet2").range("J" & sh2lastrow).PasteSpecial xlPasteValues '<-- (Pasting the copied data)
sh2lastrow = Sheets("Sheet2").range("J65536").End(xlUp).Row + 1 '<-- (Getting the last row from Sheet2)
Sheets("Sheet1").Activate
End If
Next cl
To be quite honest I am not entirely sure how to describe what it is I am trying to accomplish? But, here it goes anyway. I have an excel sheet containing one column of IDs and a second column of values that need to be associated to the first column. The problem is that the IDs in column A contain duplicates, which is okay because one ID can qualify for multiple values. What I need is to have a third column pull back the unique id, and a fourth column pull back a semi-colon delimited list of all of the values the id qualifies for. Hopefully the attached image makes sense? For what it's worth I have tried every formula I can think of, and I really know nothing about macros, which is what I am thinking needs to be implemented.
Try below code :
Sub sample()
Dim lastRowA As Long, lastRowC As Long
lastRowA = Range("A" & Rows.Count).End(xlUp).Row
lastRowC = Range("C" & Rows.Count).End(xlUp).Row
Dim rng As Range, cell As Range
Set rng = Range("C2:C" & lastRowC)
Dim rngSearch As Range
Set rngSearch = Range("A1:A" & lastRowA)
Dim rngFind As Range
Dim firstCell As String
For Each cell In rng
Set rngFind = rngSearch.Find(What:=cell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rngFind Is Nothing Then
temp = rngFind.Offset(0, 1)
firstCell = rngFind.Address
Do While Not rngFind Is Nothing
Set rngFind = rngSearch.FindNext(After:=rngFind)
If rngFind.Address <> firstCell Then
temp = temp & ";" & rngFind.Offset(0, 1)
Else
Set rngFind = Nothing
End If
Loop
End If
cell.Offset(0, 1) = temp
Next
End Sub
Here's an alternative approach, that has several advantages
it builkds the list of unique sku's
it clear old data from columns C:D
it will run much faster than looping over a range
Sub Demo()
Dim rngA As Range, rng as Range
Dim datA As Variant
Dim i As Long
Dim sh As Worksheet
Dim dic As Object
Set sh = ActiveSheet ' can change this to your worksheet of choice
Set dic = CreateObject("Scripting.Dictionary")
With sh
' Get data from columns A:B into a variant array
Set rngA = .Range(.Cells(2, 2), .Cells(.Rows.Count, 1).End(xlUp))
datA = rngA
' Create list of unique sku's and built value strings
For i = 1 To UBound(datA)
If dic.Exists(datA(i, 1)) Then
dic(datA(i, 1)) = dic(datA(i, 1)) & ";" & datA(i, 2)
Else
dic.Add datA(i, 1), datA(i, 2)
End If
Next
' Clear exisating data from columns C:D
Set rng = .Range(.Cells(2, 4), .Cells(.Rows.Count, 3).End(xlUp))
If rng.Row > 1 Then
rng.Clear
End If
' Put results into columns C:D
.Range(.Cells(2, 3), .Cells(dic.Count + 1, 3)) = Application.Transpose(dic.Keys)
.Range(.Cells(2, 4), .Cells(dic.Count + 1, 4)) = Application.Transpose(dic.Items)
End With
End Sub
How to add this:
Start the VBS editor (Alt+F11 from excel)
show project explorer, if its not already visible (Ctrl+R)
add a Module (right click on your workbook, Insert, Module)
open the module (dbl click)
Add Option Explicit as the first line, if not already there
copy paste this code into module
How to run it, from Excel
activate the sheet with your data
open macro dialog (Alt+F8)
select Demo from list and run