I am currently struggling with the following marco. I am trying to find a string in a data sheet that is taken from a userform textbox and if the string is found, I would like to copy the row and paste it into the sheet "results", then look for the string the the next row. The location of the string is in column A.
Yet, I never get any results, even when trying with just two entries of data. Could anyone help me with this issue?
Any tips would be appreciated. Many thanks in advance,
Nic
Private Sub CommandButton1_Click()
Dim uiValue As String
uiValue = Trim(ticker.Text)
Dim Sheet As Worksheet
Dim results As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell1 As Range
Dim i As Integer
Set results = Worksheets("Results")
Set Sheet = Worksheets("Database")
LastRow = Sheet.Cells(Rows.Count, 1).End(xlUp).Row
Sheet.Activate
For i = 2 To LastRow
If Cells(i, 1) = uiValue Then
Range(Cells(i, 2), Cells(i, 15)).Copy results.Range("A4000").End(xlUp).Offset(1, 0)
Sheet.Select
End If
Next i
End Sub`
Related
I have two set of range named as LIST_KEY and LIST_CAT. In Column A, user will add some data which will contain one of the one of the text from LIST_KEY. I would like to get corresponding Category list from LIST_CAT depends upon the Key value
I am using below VBA code to achieve this. This include a Array formula.
Sub match()
Dim ss As Workbook
Dim test As Worksheet
Set ss = Excel.Workbooks("test.xlsm")
Set test = ss.Worksheets("Sheet1")
For i = 2 To test.Cells(Rows.Count, "A").End(xlUp).Row
Cells(i, "B").FormulaArray = "=INDEX(LIST_CAT,MATCH(TRUE,ISNUMBER(SEARCH(LIST_KEY,RC[-1])),0))"
Cells(i, "B").Formula = Cells(i, "B").Value
Next i
End Sub
This code works perfect if there is less data to fetch. But in my original use case, I will have around 8000 rows. Due to this large number of columns excel will go to not responding state after 2-3 minutes.
Instead of adding Array formula to column B, Is there anyway to convert that into VBA to run this faster. Sorry, I am new to this VBA stuff and dont have much experience
Try the following code, which uses arrays instead of worksheet formulas...
Option Explicit
Sub GetCategories()
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Workbooks("test.xlsm")
Dim sourceWorksheet As Worksheet
Set sourceWorksheet = sourceWorkbook.Worksheets("Sheet1")
Dim lookupArray As Variant
lookupArray = sourceWorkbook.Names("LIST_KEY").RefersToRange.Value
Dim returnArray As Variant
returnArray = sourceWorkbook.Names("LIST_CAT").RefersToRange.Value
Dim tableArray As Variant
Dim lastRow As Long
With sourceWorksheet
lastRow = .Cells(.Rows.Count, "a").End(xlUp).Row
tableArray = .Range("A2:B" & lastRow).Value
End With
Dim desc As String
Dim i As Long
Dim j As Long
For i = LBound(tableArray, 1) To UBound(tableArray, 1)
desc = tableArray(i, 1)
For j = LBound(lookupArray, 1) To UBound(lookupArray, 1)
If InStr(1, desc, lookupArray(j, 1), vbTextCompare) > 0 Then
tableArray(i, 2) = returnArray(j, 1)
Exit For
End If
Next j
Next i
sourceWorksheet.Range("B2").Resize(UBound(tableArray, 1), 1).Value = Application.Index(tableArray, 0, 2)
End Sub
I need help and I'm hoping someone here can help me :)
I have a workbook that runs some reports from Avaya CMS. It runs the report and creates a new sheet for each persons name on the MAIN sheet. << This part works wonderfully.
My issue is I cannot figure out how to use that range of names on the MAIN sheet to select only those specific sheets and then copy them to a new workbook.. There's 2 other hidden sheets as well.. Which is why I think using the range of names is easier but I'm open to anything at this point.
Here's an screeshot of what it looks like :
Sorry, I couldn't figure out how to upload the workbook here but the image should, hopefully, be good enough. Thank you for your time and help!
Here's an image with the hidden sheets.
I need it to exclude the first 3 sheets/
And here's the code:
Sub Macro1()
Dim sheetArray() As String
Dim i As Integer
i = 0
For Each c In MainSheet.Range("A2:A20").Cells
ReDim Preserve sheetArray(0 To i)
sheetArray(i) = c.Value
i = i + 1
Next
Sheets(sheetArray).Select
End Sub
Sub move_Sheets()
Dim mSH As Worksheet
Set mSH = ThisWorkbook.Sheets("Main")
Dim shArray() As String
Dim i As Integer
i = mSH.Range("A" & Rows.Count).End(xlUp).Row
ReDim Preserve shArray(0 To i - 2)
For a = 2 To i
shArray(a - 2) = mSH.Range("A" & a).Value
Next a
ThisWorkbook.Sheets(shArray).Move
End Sub
You could try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, sheetIndex As Long
Dim SheetName As String
Dim ws As Worksheet
With ThisWorkbook.Worksheets("Main")
'Last row of column where the names appears
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop the column from row 2 to last row
For i = 2 To LastRow
'Set Sheet name
SheetName = .Range("A" & i).Value
'Check if the sheet with the SheetName exists
If DoesSheetExists(SheetName) Then
'Insert the code to code
sheetIndex = Workbooks("Book2").Sheets.Count
ThisWorkbook.Worksheets(SheetName).Copy After:=Workbooks("Book2").Sheets(sheetIndex)
Else
End If
Next i
End With
End Sub
Function DoesSheetExists(SheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(SheetName)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function
I have a workbook with two worksheets.
The first sheet contains a list of email adresses.
The second sheet contains a list of email adresses of which some match the ones in first sheet and some may not
I added a button and some code (see below). When i hit the button excel looks in sheet2 and compares it with the email addresses in sheet1 ... if it finds equal email-addresses it adds the found email address & the "allowed"-state behind the existing address in sheet1.
This is working fine:
Private Sub CommandButton1_Click()
Call lookup
End Sub
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("Tabelle1").Select
TotalRows = ActiveSheet.UsedRange.Rows.Count
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = Sheets("Tabelle2").UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 2).Value = rng.Value
Cells(i, 3).Value = "Allowed"
End If
Next
End Sub
But now I want to have the button in one "trigger.xlsm"-file and the data is in two different workbooks. ...so i have one button to copy the compare data from workbook2 to sheet2 in workbook1.... this works well!
But the rest of the code that compares and writes the equal mail-addresses in workbook1 - sheet1 does not... every line is filled with "allowed"-state.
I tried with this code which gives the above result:
Private Sub CommandButton1_Click()
Workbooks.Open "C:\Users\DEJP0050\Documents\testvon.xlsx"
Workbooks.Open "C:\Users\DEJP0050\Documents\testnach.xlsm"
Workbooks("testvon.xlsx").Sheets("Tabelle1").Range("A:A").Copy _
Workbooks("testnach.xlsm").Sheets("Tabelle2").Range("A:A")
Workbooks("testvon.xlsx").Close SaveChanges:=True
Workbooks("testnach.xlsm").Close SaveChanges:=True
End Sub
Private Sub CommandButton2_Click()
Call lookup
End Sub
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
Dim wb1 As Excel.Workbook
Set wb1 = Workbooks.Open("C:\Users\DEJP0050\Documents\testnach.xlsx")
Dim ws11 As Worksheet
Set ws11 = wb1.Sheets("Tabelle1")
Dim ws12 As Worksheet
Set ws12 = wb1.Sheets("Tabelle2")
'Copy lookup values from sheet1 to sheet3
'ws11.Select
TotalRows = ws11.UsedRange.Rows.Count
'Range("A1:A" & TotalRows).Copy
Destination:=Sheets("Tabelle3").Range("A1")
'Go to the destination sheet
'Sheets("Tabelle3").Select
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = ws12.UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
ws11.Cells(i, 2).Value = rng.Value
'Cells(i, 2).Value = "Allowed"
ws11.Cells(i, 3).Value = "Allowed"
End If
Next
Workbooks("testnach.xlsx").Close SaveChanges:=True
End Sub
Why does it work when the button is within the same workbook, but doesnt work when the button is in another workbook?
Maybe you need to change
Sheets("Tabelle1").Select
to
activeworkbook.Sheets("Tabelle1").Select
AND
TotalRows = ActiveSheet.UsedRange.Rows.Count
to
TotalRows = activeworkbook.ActiveSheet.UsedRange.Rows.Count
AND
Set rng = Sheets("Tabelle2").UsedRange.Find(Cells(i, 1).Value)
to
Set rng = activeworkbook.Sheets("Tabelle2").UsedRange.Find(activeworkbook.Sheets("Tabelle2").Cells(i, 1).Value)
I'm attempting my first VBA code and I keep getting a run time error at this specific place in my code:
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Here is the actual code:
Sub Test_loop()
' Testing loop for highlighting
Dim lastrow As Long
Dim datevar As String
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
datevar = Format(ws.Cells(i, 2), "mm/dd")
If ws.Cells(i, 3) = "Received" And datevar = "11/24" Then
Cells(i, 1).Interior.Color = RGB(rrr, ggg, bbb)
End If
Next i
End Sub
My goal is to go though the last cell of my row and find a cell with a specific date that has a cell to the right with a specific text. Then it would highlight the first cell in that row and loop on to the next row. I'm not too sure where I went wrong and why I am getting an error.
would appreciate the help
The code is producing an error because ws isn't set to any actual worksheet. Here's how to fix this:
add Option Explicit as the first line in the module. This will let
Excel catch any undeclared variables
declare ws as a variable of
type Worksheet using a Dim statement. Also add declarations any
other variables that we use later - i, rrr, ggg, bbb
make ws point to an actual worksheet using a Set statement
Putting this together gives us:
Option Explicit
Sub Test_loop()
' Testing loop for highlighting
Dim lastrow As Long
Dim datevar As String
' These variables weren't declared in the original code
Dim ws As Worksheet
Dim i As Integer
Dim rrr As Integer
Dim ggg As Integer
Dim bbb As Integer
' ws needs to be set to an actual sheet - Sheet1 is used here
' but replace this with the name of the actual sheet you need
'
' ws will be set to the worksheet called Sheet1 in whichever
' workbook is active when the code runs - this might not be
' the same workbook that the code is stored in
Set ws = Worksheets("Sheet1")
' For consistency, need to qualify Rows.Count with
' a worksheet
lastrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
datevar = Format(ws.Cells(i, 2), "mm/dd")
If ws.Cells(i, 3) = "Received" And datevar = "11/24" Then
Cells(i, 1).Interior.Color = RGB(rrr, ggg, bbb)
End If
Next i
End Sub
I have a vba code that copies rows on a sheet to another sheet depending if column A = 1 and it works perfectly. I am trying to make it paste to the next available row instead of overwriting the data that is already there in order to make a log. Here is the code I have already but I can't seem to figure out how to make it paste to the next available row. Any help would be greatly appreciated! Thanks in advance!
Sub Log()
Dim rng As Range
Dim lastRow As Long
Dim cell As Variant
Dim count As Long
count = 0
With ActiveSheet
lastRow = .Range("A" & .Rows.count).End(xlUp).Row
Set rng = .Range("A3:A" & lastRow)
For Each cell In rng
If cell.Value = "1" Then
Range(cell.Offset(0, 1), cell.Offset(0, 6)).Copy
Range("'Log'!B3").Offset(count, 0).PasteSpecial xlPasteValues
count = count + 1
End If
Next
End With
End Sub
You just need to loop through the source sheet.
Try using .Cells(row,col) instead of Range..
This example is heavy on the comments to help understand the looping process.
You will need a few additional Functions to make this work using this code.
LastRow Function
Function lastRow(sheet As String) As Long
lastRow = Sheets(sheet).Cells(Rows.Count, "A").End(xlUp).Row 'Using Cells()
End Function
LastCol Function
Function lastCol(sheet As String) As Long
lastCol = Sheets(sheet).Cells(2, Columns.Count).End(xlToLeft).Column
End Function
Code for solution: Assuming you have your target sheet's headers already set up AND the target and source sheet share the same formatting.
Sub Log()
Dim source As String, target As String
Dim sRow As Long, col As Long, tRow As Long
'Declare Sheets
source = "Sheet1"
target = "Sheet2"
'Loop through rows of source sheet
For sRow = 2 To lastRow(source)
'Get current last row of Target Sheet
tRow = lastRow(target) + 1
'Meet criteria for Column A to = 1 on Source
If Sheets(source).Cells(sRow, 1) = "1" Then
'Copy each column of source sheet to target sheet in same order
For col = 1 To lastCol(source)
Sheets(target).Cells(tRow, col) = Sheets(source).Cells(sRow, col)
Next col
End If
Next sRow
End Sub