I am creating a VBA application that will find the text that I have entered in a certain range (Should be dynamic, in order for me to input more in the future). With that the entered texts in the range will look for the words in another sheet column:
Example:
And it will look for the words inputted in another sheet.
Dim Main as Worksheet
Set Main = Sheets("Sheet1")
Dim Raw2 as Worksheet
Set Raw2 = Sheets("Sheet2")
LookFor = Main.Range(D8:100)
Fruits = Raw2.Range("G" & Raw2.Rows.Count).End(xlUp).row
For e = lastRow To 2 Step -1
value = Raw2.Cells(e, 7).value
If Instr(value, LookFor) = 0 _
Then
Raw2.Rows(e).Delete
Honestly I am not sure how to proceed. And the mentioned code is just experiment. Desired output is to delete anything in sheet2 except for the rows that contain the words that I have inputted in the "Look for the words". Hope you can help me. Thank you.
This should do the trick :
Sub Sevpoint()
Dim Main As Worksheet
Set Main = Sheets("Sheet1")
Dim Raw2 As Worksheet
Set Raw2 = Sheets("Sheet2")
Dim LooKFoR() As Variant
Dim LastRow As Double
Dim i As Double
Dim j As Double
Dim ValRow As String
Dim DelRow As Boolean
LooKFoR = Main.Range(Main.Range("G8"), Main.Range("G" & Main.Rows.Count).End(xlUp)).Value
LastRow = Raw2.Range("G" & Raw2.Rows.Count).End(xlUp).Row
For i = LastRow To 2 Step -1
ValRow = Raw2.Cells(i, 7).Value
DelRow = True
'MsgBox UBound(LooKFoR, 1)
For j = LBound(LooKFoR, 1) To UBound(LooKFoR, 1)
If LCase(ValRow)<>LCase(LooKFoR(j, 1)) Then
Else
DelRow = False
Exit For
End If
Next j
If DelRow Then Raw2.Rows(i).Delete
Next i
End Sub
Related
I have an excel sheet which looks like this - All the data is numerical data. The actual sheet has a lot more rows & columns in reality.
https://i.imgur.com/E2HEdXF.png
What I Want to get out of this data is something like this - For each year, I want to sort A & F based on the year's numerical data. So not one sort, but one sort per year.
I don't think there is a simple method for doing this, so I was thinking of 2 possible ways
I export the data into some database & then use SQL queries to get the output I want - I assume there must be some databases which allow you import Excel data.
or
Write a VBA program which does the following - Copy Column D & E into another place & sort based on Column E. Then Copy Column D & F into another place & sort based on Column F & so on & so forth.
I have never done VBA, but I am programmer, so I assume it wouldn't be trouble to do this.
However, I was wondering if there is some other easier way to do it or if not, which of the above two would be a better way to do it.
Copy and Sort
The following will copy the data from columns D:G as column pairs consisting of the first column and each next column, to columns A:B of newly created worksheets of the workbook containing this code and finally sort them descendingly by column B. Already existing worksheets, to be created, will previously be deleted.
Adjust the values in the constants section.
Option Explicit
Sub copyAndSort()
Const sName As String = "Sheet1"
Const sFirst As String = "D1"
Const yCols As String = "E:G"
Const dFirst As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range
Dim yrg As Range
Dim rCount As Long
Dim cCount As Long
With sws.Range(sFirst)
Dim rOff As Long: rOff = .Row - 1
Dim sCell As Range
Set sCell = .Resize(.Worksheet.Rows.Count - rOff) _
.Find("*", , xlFormulas, , , xlPrevious)
If sCell Is Nothing Then Exit Sub
rCount = sCell.Row - rOff
Set srg = .Resize(rCount)
Set yrg = .Worksheet.Columns(yCols).Rows(.Row).Resize(rCount)
cCount = yrg.Columns.Count
End With
Dim sData As Variant: sData = srg.Value
ReDim Preserve sData(1 To rCount, 1 To 2)
Dim yData As Variant: yData = yrg.Value
Dim Result As Variant: ReDim Result(1 To cCount)
Dim c As Long, r As Long
For c = 1 To cCount
Result(c) = sData
For r = 1 To rCount
Result(c)(r, 2) = yData(r, c)
Next r
Next c
Erase yData
Erase sData
Dim dws As Worksheet
Dim drg As Range
Dim dName As String
Application.ScreenUpdating = False
For c = 1 To cCount
dName = Result(c)(1, 2)
On Error Resume Next
Set dws = Nothing
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dName
Set drg = dws.Range(dFirst).Resize(rCount, 2)
drg.Value = Result(c)
drg.Sort Key1:=drg.Cells(2), Order1:=xlDescending, Header:=xlYes
Next c
wb.Save
Application.ScreenUpdating = True
End Sub
I'm having a problem with my excel program. I want to make the names and the telephone numbers to paste at the other sheet, but names must be sorted randomly and the phone numbers must be the same. For Example at the first sheet i have Kalin Kalinov +22222222 and Martin Martinov +99119911 and at the other sheet after the copy paste action they must be like Martin Martinov +99119911 and Kalin Kalinov +22222222.
Sub GenerateNames()
Dim ssheet1 As Worksheet
Dim rnsheet As Worksheet
Set ssheet1 = ThisWorkbook.Sheets("Sheet1")
Set rnsheet = ThisWorkbook.Sheets("RandomNames")
ssheet1.Range("A3:A70").Copy rnsheet.Range("A3:A70")
ssheet1.Range("B3:B70").Copy rnsheet.Range("B3:B70")
End Sub
Add something like this, and apply it either on the source sheet or on the target sheet:
Range("C3").Formula = "=RAND()"
Range("C3").AutoFill Destination:=Range("C3:C70")
Range("A:C").Sort key1:=Range("C3"), order1:=xlAscending, Header:=xlYes
It creates a column of random values, used for sorting. You might want to delete it afterwards.
Sub randomName()
Dim ws As String, ws2 As String, rg As Range, rg2 As Range
Dim DataRange As Variant, i As Integer
Dim n As Integer, tmp As String
Dim nData As Integer
'== set by user
nData = 70 '== data size
ws = "sheet1": ws2 = "RandomNames" '== sheets name
Set rg = Sheets(ws).Cells(3, 1): Set rg2 = Sheets(ws2).Cells(3, 1) '=range with start row
'== Run
rg2.Resize(nData, 2).Value = rg.Resize(nData, 2).Value
DataRange = rg.Resize(nData).Value
For i = 1 To UBound(DataRange)
n = CLng(Rnd(i) * Second(Now) * 100) Mod UBound(DataRange) + 1
If i <> n Then tmp = DataRange(n, 1): DataRange(n, 1) = DataRange(i, 1): DataRange(i, 1) = tmp
Next i
rg2.Resize(nData) = DataRange: Set rg = Nothing: Set rg2 = Nothing
End Sub
I'd like the code to paste 'cashb' underneath 'rngcel', but every time
I run the code 'cashb''s value appears above 'rngCel'.value. Rngcell's range is from A2:A34, I'd like 'Cashb' to appear right below it at A35. I tried putting 'A35' in the
range but it does not work.
This is the code that I want to appear below rngcel.value.
Sheets(" Price").Range("A35").Resize(Cashb.Rows.Count).Value = Cashb.Value
I'd also like to return the column that's 5 columns to the right of "cashb"range
I appreciate any help that I receive.
This is the code that I have.Thanks in advance.
Sub liveP()
Application.ScreenUpdating = False
Dim rngTicker As Range
Dim rngCel As Range
Dim Cashb As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Live"
Set rngTicker = Worksheets("prices").Range("H16:H200")
Set Cashb = Sheets("prices").Range("cashbalances")
For Each rngCel In rngTicker
If rngCel.Font.ColorIndex = 33 Then
Worksheets("Live").Cells(Rows.Count, 1).End(xlUp).offset(1).Resize(1, 2).Value = Array(rngCel.offset(, "-7").Value, rngCel.Value) ' this is range cell value'
WorkSheets("Live").Range("A35").Resize(Cashb.Rows.Count).Value = Cashb.Value.offset ' this is the value I'd like to appear under rngcel value
'New data that im posting on the Live sheet'
Sheets("Live").Range("C2:H33").Formula = "=($B2 +$C5)"
Sheets("Live").Range("A1") = "Header1"
Sheets("Live").Range("B1") = "Header2"
Sheets("Live").Range("C1") = "Header3"
Sheets("Live").Range("D1") = "Header4"
Sheets("Live").Range("E1") = "Header5"
Sheets("Live").Range("F1") = "Header6"
End If
Next
Application.ScreenUpdating = True
End Sub
Try This
Sub liveP()
Application.ScreenUpdating = False
Dim rngTicker As Range
Dim rngCel As Variant 'used in for each this should be variant
Dim Cashb As Range
Dim ws As Worksheet
Dim LastRow As Long 'dimensioned variable for the last row
Dim CashbRows As Long 'dimensioned variable for Cashb rows
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Live"
Set rngTicker = Worksheets("prices").Range("H16:H200")
Set Cashb = Sheets("prices").Range("cashbalances")
'Assuming "cashbalances" is a named range in the worksheet
CashbRows = Cashb.Rows.Count
For Each rngCel In rngTicker
If rngCel.Font.ColorIndex = 33 Then
With Worksheets("Live")
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 'set lastrow variable
.Cells(LastRow, 1) = rngCel.Offset(0, -7).Value 'putting value 7 columns before into live worksheet column A
.Cells(LastRow, 2) = rngCel.Value 'putting value into live worksheet column B
.Range(.Cells(35, 1), .Cells(35 + CashbRows, 1)) = Cashb.Offset(, 5).Value 'im not really sure if this line is going to work at all
'New data that im posting on the Live sheet'
.Range("C2:H33").Formula = "=($B2 +$C5)"
.Range("A1") = "Header1"
.Range("B1") = "Header2"
.Range("C1") = "Header3"
.Range("D1") = "Header4"
.Range("E1") = "Header5"
.Range("F1") = "Header6"
End With
End If
Next
Application.ScreenUpdating = True
End Sub
Modifications:
rngCel is now a variant not a range
Using a LastRow Variable to get away from offset
Removed the array when placing data into "LIVE" because why not
CashbRows will now only be calculated one time before the loop. Saving time
The With Worksheets("Live") statement is a time saving measure.
You were calling A35 as a range, which it is not, then resizing to a range maybe? Hard to know when I cant tell what "cashbalances" is. If "cashbalances is only 1 row or may ever be 1 row, then you will need to add an If Then Else control to handle it.
Also A35 gets overwritten every single loop... so not sure what you want to do there.
I hope I was able to understand your questions well enough to get you going in the right direction.
EDIT
Stop treating "cashbalances" as a named range. I believe VBA is hanging onto the original row numbers of the range, similar to how Variant arrays start at 1 when assigned as I do in the following. It does not look like you are modifying "cashbalances" so create a variant array before the loop but after CashbRows.
EXAMPLE:
Dim CB() as variant, j as long
with sheets("PUT THE SHEET NAME OR INDEX HERE")
CB = .range(.cells(1,6), .cells(CashbRows,6)).value 'address to whatever .offset(,5) is
'i assumed cashb was in column A
Instead of .Range(.Cells(35, 1), .Cells(35 + CashbRows, 1)) = Cashb.Offset(, 5).Value Use:
For j = 1 to CashbRows
.cells(34 + j, 1) = CB(j)
Next j
I have an Excel Form that I use, It holds 3 Worksheets - Form, Data and Entries. Basically When you call a new Form with the Button it looks for the lastrow in the Entries sheet (Range "A") adds 1 and that's your new Form ID. Having multiple users use this form I have it set that It also adds the number in the Entries sheet before the form is filled, in order to reserve it so a next user cannot get duplicates.
Here's where I get caught up. I'd like to have currentrow find that sheet id and paste the data in that row, but the code I have is just adding a new row.
This is what it looks like.
Sub Submit()
Dim rng1 As Range
Dim rng2 As Range
Dim multiplerange As Range
Dim currentrow As Long
Dim sheetid As String
Set rng1 = Range("M1,M2,B2,F6,B7,B8,B9,B11,D11,B13,D13,I6,M6,I7,I8,I9,I11,K11,I13,K13,B15,B18,B22,E22,B23,B24,B26,E26,I22,J22,M22,K24,M24,I24,I26,K26,M26,B29,E29,B30,B31,B33,E33,I29,J29,M29,K31,M31,I31,I33,K33,M33,B36,E36,B37,B38,B40,E40,I36,J36,M36,K38,M38,I38,I40,K40,M40")
Set rng2 = Range("G2")
Set multiplerange = Union(rng1, rng2)
Dim WSEntries As Worksheet
Dim WSForm As Worksheet
Set WSEntries = Sheets("Entries")
Set WSForm = Sheets("Form")
sheetid = WSForm.Range("M1").Text
Dim lastrow As Integer
lastrow = WSEntries.Cells(Rows.Count, "A").End(xlUp).Row
For currentrow = 3 To lastrow
If Cells(currentrow, 1) = sheetid Then
Dim i As Integer
i = 1
For Each c In multiplerange
WSEntries.Cells(currentrow + 1, i) = c
i = i + 1
Next
Else
i = 1
For Each c In multiplerange
WSEntries.Cells(lastrow + 1, i) = c
i = i + 1
Next
End If
Next
End Sub
Any help would be great. Thanks
Edit: I also didn't add all my declared items but this is the other part of the script. I've got everything else working just the paste part that I'm having issue with
Got it working!! switched to a Range method
lastrow = WSEntries.Cells(Rows.Count, "A").End(xlUp).Row
For currentrow = 3 To lastrow
If WSEntries.Range("A" & currentrow) = sheetid Then
Dim i As Integer
i = 1
For Each c In multiplerange
WSEntries.Cells(currentrow, i) = c
i = i + 1
I have a table with two rows : the first row contains the locations where the value of the second row should be pasted.
For example :
row 1 : sheet8!D2 sheet6!D2 sheet2!C5
row 2 : apple lemon pEER
So apple should be pasted in sheet 8 cell D8. Lemon should be pasted in sheet6 cell D2. The problem is that the value apple is pasted everywhere (in sheet8!D2, sheet6!D2 and sheet2!C5). How can I correct this?
Sub Sample()
Dim rng As Range
Dim Sh As String, Cl As String
Dim ws As Worksheet
Dim i As Integer
Dim Row1 As String
ncol = Range("A1:F1").Columns.Count
For i = 1 To ncol
Row1 = Range("A1:F1").Cells(1, i).Value
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
Sh = Split(Row1, "!")(0)
Cl = Split(Row1, "!")(1)
Set rng = ThisWorkbook.Sheets(Sh).Range(Cl)
rng.Value = .Range("A2").Value
End With
Next i
End Sub
There are a few issues with your code. First up its good practice to put Option Explicit at the top of each module, this will ensure variables are defined (ncol is not defined).
The following code will fix the problem although it could be tweaked in various ways. The main problem is you don't quite set the referencing ranges correctly, you move through the columns with your loop but always refer back to cell A2. Assuming your input data is on rows 1 and 2 and run from the sheet with that data this will work.
Sub SampleFixed()
Dim rng As Range
Dim Sh As String, Cl As String
Dim ws As Worksheet
Dim i As Integer, ncol As Integer
Dim Row1 As String
ncol = Range("A1:F1").Columns.Count
For i = 1 To ncol
Set ws = ActiveSheet
With ws
Row1 = .Cells(1, i).Value
If Len(Row1) > 0 Then
Sh = Split(Row1, "!")(0)
Cl = Split(Row1, "!")(1)
Set rng = ThisWorkbook.Sheets(Sh).Range(Cl)
'Here you were always refering to cell A2 not moving through the values which was the main problem.
rng.Value = .Cells(2, i).Value
End If
End With
Next i
End Sub