Hello Friends and Community,
I have been getting a VBA error with my code "Application-defined or object defined error'
Here is my code
Sub RSData()
Dim Column6 As Integer
Dim RowX As Integer
Dim EndofRow As Integer
EndofRow = Cells(Rows.Count, 2).End(xlUp).Row
For RowX = 14 To EndofRow
If Cells(RowX, 12) = "RS" Then
For Column6 = 13 To 34
Cells(RowX, Column6) = Application.WorksheetFunction.VLookup(Cells(RowX, 11), Worksheets("Base Data_RS").Columns("F:AH"), Column6 - 11, 0)
Next Column6
Else: Cells(RowX, Column6) = Null
End If
Next RowX
End Sub
The weird thing is my previous code which is almost the same as this one runs fine, the only difference is the sheet that I am vlooking up agasint to, and the if criteria. Here is the previous code that works fine
And the error line happens in ' Else: Cells(RowX, Column6) = Null'
Any help will be greatly appreciated!
Sub CRSData()
Dim Column6 As Integer
Dim RowX As Integer
Dim EndofRow As Integer
EndofRow = Cells(Rows.Count, 2).End(xlUp).Row
For RowX = 14 To EndofRow
If Cells(RowX, 12) = "CRS" Then
For Column6 = 13 To 34
Cells(RowX, Column6) = Application.WorksheetFunction.VLookup(Cells(RowX, 11), Worksheets("Base Data_CRS").Columns("F:AH"), Column6 - 11, 0)
Next Column6
Else: Cells(RowX, Column6) = Null
End If
Next RowX
End Sub
Related
I have two sheets where I am trying to check to make sure one column has the same values as the other column on the other sheet.
On one sheet, the values are interlaced with names on the same column. Whilst on the other sheet the values are on a single column by themselves.
Sheet1 Sheet2
Column1 Column 2
Column1 Name1 rate1
Name1 Name2 rate2
rate1 Name3 rate3
Name2
rate2
Name3
rate3
I want Excel to be able to look at rate1 in Sheet1 and see if it matches rate1 in Sheet2 and if there is a difference, highlight the cell red in Sheet2. If the rate in Sheet1 is "N/A", leave it alone and don't highlight red.
I'm having trouble with reading from the correct cells and getting it to skip the names in Sheet1.
Here is my code: (It's messy...)
Sub ratetest()
Dim calc As Double
Dim rate As Double
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim a As Integer
Dim b As Integer
'rate = ThisWorkbook.Sheets("Sheet1").Cells(a, 9)
'calc = ThisWorkbook.Sheets("Sheet2").Cells(b, 4)
a = 13
b = 2
For a = 13 To ws1.Range("I45").End(xlUp).Row Step 2
For b = 2 To ws1.Range("D17").End(xlUp).Row
If ws1.Cells(a, 9) <> ws2.Cells(b, 4) Or ws1.Cells(a, 9) <> "N/A" Then
' do nothing...
Else
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next b
Next a
End Sub
This will highlight in red all cells on Sheet2-Col D not found on Sheet1-Col I:
Option Explicit
Public Sub RateTest1()
Const COLUMN_1 = "I", WS1_START = 12
Const COLUMN_2 = "D", WS2_START = 2
Dim ws1 As Worksheet, ws2 As Worksheet, col1 As Variant, col2 As Variant, tr As Long
Dim max1 As Long, max2 As Long, r1 As Long, r2 As Long, red As Long, found As Boolean
Dim miss As Range
tr = Rows.Count: red = RGB(255, 0, 0)
Set ws1 = ThisWorkbook.Sheets("Sheet1"): max1 = ws1.Cells(tr, COLUMN_1).End(xlUp).Row
Set ws2 = ThisWorkbook.Sheets("Sheet2"): max2 = ws2.Cells(tr, COLUMN_2).End(xlUp).Row
col1 = ws1.Range(ws1.Cells(1, COLUMN_1), ws1.Cells(max1, COLUMN_1))
col2 = ws2.Range(ws2.Cells(1, COLUMN_2), ws2.Cells(max2, COLUMN_2))
For r2 = WS2_START To max2 'check each value on sheet 2, col D
For r1 = WS1_START To max1 Step 2 'check every 2nd value on sheet 1, col I
If Len(col1(r1, 1)) > 0 And col1(r1, 1) <> "N/A" Then 'cell.sheet1 not empty
found = (col1(r1, 1) = col2(r2, 1)) 'if c.sheet1 = c.sheet2 -> is found
If found Then Exit For
End If
Next
If Not found Then
If miss Is Nothing Then
Set miss = ws2.Cells(r2, COLUMN_2)
Else
Set miss = Union(miss, ws2.Cells(r2, COLUMN_2))
End If
End If
Next
miss.Interior.Color = red
End Sub
I have 2 sets of data in 2 sheets having same columns in each sheet.
I want to copy both the sets of data from 2 sheets into a 3rd sheet but in the following format:-
Sheet1
Name Age Gender
Mayur 23 M
Alex 24 M
Maria 25 F
April 19 F
Sheet2
Name Age Gender
Mayur 21 M
Maria 24 F
Alex 24 M
June 20 F
Sheet3
Name1 Name2 Age1 Age2 Gender1 Gender2
Mayur Mayur 23 21 M M
Alex Alex 24 24 M M
Maria Maria 25 24 F F
April 19 F
June 20 F
Now there is one primary column i.e. Name. This column will never be empty.
Both the sheets may not have the data in the same sequence.
Both the sheets may have different entries for the same name.
There could be a name missing in any of the sheets
I have written the whole code which does the following:-
I find out Names from sheet1 in sheet2 & then copy corresponding entries for that name from both the sheets to sheet3.
If a name is not found in sheet2 then it's data is copied as it is as shown above & finally Names in sheet2 are searched in sheet1 if any name is not present in there those entries are copied in sheet3.
Now the searching part runs quite well performance wise but the copying part takes a lot of time.
I have tried other methods of copying the data as well but none runs quite fast.
In actual data there are more than 200 columns & millions of rows.
The whole process runs for more than 6-7 hours.
Could anyone please let me know any alternative faster way of achieving this.
Even if that could reduce the time to an hour or 2 from 7 hours that's still great.
Also I need to highlight the descrepancies which I'm doing that by changing the cell color when there is a mismatch in the data while copying from both the sheets.
Below is the code
Sub findUsingArray()
Dim i As Long
Dim j As Variant
Dim noOfColumnsA As Integer
Dim maxNoOfColumns As Integer
Dim noOfRowsA As Long
Dim noOfRowsB As Long
Dim arrayColumnA() As Variant
Dim arrayColumnB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim primaryKeyColumn As Integer
Dim result As Long
Set sheet1 = ThisWorkbook.Sheets("Sheet1")
Set sheet2 = ThisWorkbook.Sheets("Sheet2")
noOfColumnsA = sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
maxNoOfColumns = noOfColumnsA * 2
noOfRowsA = sheet1.Cells(Rows.Count, 1).End(xlUp).Row
noOfRowsB = sheet2.Cells(Rows.Count, 1).End(xlUp).Row
'createHeader maxNoOfColumns Used to create header in 3rd sheet
primaryKeyColumn = 1
ReDim arrayColumnA(noOfRowsA)
ReDim arrayColumnB(noOfRowsB)
arrayColumnA = sheet1.Range(sheet1.Cells(1, primaryKeyColumn), sheet1.Cells(noOfRowsA, primaryKeyColumn))
arrayColumnB = sheet2.Range(sheet2.Cells(1, primaryKeyColumn), sheet2.Cells(noOfRowsB, primaryKeyColumn))
result = 2
For i = 2 To noOfRowsA
j = Application.Match(arrayColumnA(i, 1), sheet2.Range(sheet2.Cells(1, primaryKeyColumn), sheet2.Cells(noOfRowsB, primaryKeyColumn)), 0)
If Not IsError(j) Then
result = copyInaRowUsingArray(i, result, j, maxNoOfColumns)
Else
result = copyMissingRow(1, i, result, maxNoOfColumns)
End If
Next i
For i = 2 To noOfRowsB
j = Application.Match(arrayColumnB(i, 1), sheet1.Range(sheet1.Cells(1, primaryKeyColumn), sheet1.Cells(noOfRowsA, primaryKeyColumn)), 0)
If IsError(j) Then
result = copyMissingRow(2, i, result, maxNoOfColumns)
End If
Next i
End Sub
Function copyInaRowUsingArray(sheet1Index As Long, newRowIndex As Long, sheet2index As Variant, noOfColumns As Integer)
Dim i As Long
Dim j As Long
Dim val As Variant
Dim valueA As String
Dim valueB As String
Dim arrayA() As Variant
Dim arrayB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim sheet3 As Worksheet
Dim rowColoured As Boolean
j = 1
Set sheet1 = ThisWorkbook.Sheets("Sheet1")
Set sheet2 = ThisWorkbook.Sheets("Sheet2")
Set sheet3 = ThisWorkbook.Sheets("Sheet3")
arrayA = Application.Transpose(Application.Transpose(sheet1.Range(sheet1.Cells(sheet1Index, 1), sheet1.Cells(sheet1Index, noOfColumns)).Value))
arrayB = Application.Transpose(Application.Transpose(sheet2.Range(sheet2.Cells(sheet2index, 1), sheet2.Cells(sheet2index, noOfColumns)).Value))
rowColoured = False
With sheet3
For i = 1 To noOfColumns
valueA = arrayA(j)
If Not valueA = "" Then
.Cells(newRowIndex, i).Value = valueA
End If
i = i + 1
valueB = arrayB(j)
If Not valueB = "" Then
.Cells(newRowIndex, i).Value = valueB
End If
If Not StrComp(CStr(valueA), CStr(valueB)) = 0 Then
If Not rowColoured Then
.Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 35
rowColoured = True
End If
.Cells(newRowIndex, i).Interior.ColorIndex = 34
.Cells(newRowIndex, i - 1).Interior.ColorIndex = 34
End If
j = j + 1
Next i
copyInaRowUsingArray = newRowIndex + 1
End With
End Function
Function copyMissingRow(sheetNo As Integer, sheetIndex As Long, newRowIndex As Long, noOfColumns As Integer)
Dim i As Long
Dim j As Long
Dim val As Variant
Dim valueA As String
Dim valueB As String
Dim arrayA() As Variant
Dim arrayB() As Variant
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim sheet3 As Worksheet
j = 1
Set sheet3 = ThisWorkbook.Sheets("Sheet3")
With sheet3
If sheetNo = 1 Then
Set sheet1 = ThisWorkbook.Sheets("Sheet1")
ReDim arrayA(noOfColumns)
arrayA = Application.Transpose(Application.Transpose(sheet1.Range(sheet1.Cells(sheetIndex, 1), sheet1.Cells(sheetIndex, noOfColumns)).Value))
For i = 1 To noOfColumns
valueA = arrayA(j)
If Not valueA = "" Then
.Cells(newRowIndex, i).Value = valueA
End If
i = i + 1
j = j + 1
Next i
.Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 46
Else
Set sheet2 = ThisWorkbook.Sheets("Sheet2")
ReDim arrayB(noOfColumns)
arrayB = Application.Transpose(Application.Transpose(sheet2.Range(sheet2.Cells(sheetIndex, 1), sheet2.Cells(sheetIndex, noOfColumns)).Value))
For i = 1 To noOfColumns
i = i + 1
valueB = arrayB(j)
If Not valueB = "" Then
.Cells(newRowIndex, i).Value = valueB
End If
j = j + 1
Next i
.Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 3
End If
copyMissingRow = newRowIndex + 1
End With
End Function
As per one of the comments, a dictionary should help do what it is you're after. The dictionary used here saves, from sheet(2), the name as the key and the corresponding row as the value.
Option Explicit
Sub CopyRng(frmSht As Worksheet, frmRow As Integer, offset As Integer, toRow As Integer)
Dim r As Integer
For r = 1 To 3:
Sheets(3).Cells(toRow, offset + 2 * r).Value = frmSht.Cells(frmRow, r).Value
Next
End Sub
Sub InterleaveRows()
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Sheets(2)
Dim r As Integer, r2 As Integer, r3 As Integer: r3 = 2
Dim val As String
For r = 2 To .Range("A" & .Rows.Count).End(xlUp).row:
dict(.Cells(r, "A").Value) = r
Next
End With
CopyRng Sheets(1), 1, -1, 1
CopyRng Sheets(2), 1, 0, 1
For r = 2 To Sheets(1).Range("A" & Sheets(1).Rows.Count).End(xlUp).row:
val = Sheets(1).Cells(r, "A").Value
If (dict.Exists(val)) Then
r2 = dict(val)
CopyRng Sheets(1), r, -1, r3
CopyRng Sheets(2), r2, 0, r3
dict.Remove val
Else
CopyRng Sheets(1), r, -1, r3
End If
r3 = r3 + 1
Next
For r = 0 To dict.Count - 1
r2 = dict.items()(r)
CopyRng Sheets(2), r2, 0, r3
r3 = r3 + 1
Next
End Sub
The first loop of the 'InterLeaveRows' subroutine populates the dictionary by going through all the entries in Sheet(2). The next two lines writes out the header to sheet(3). The 2nd loop then writes out all values to Sheet(3) that are either in the dictionary (ie in both Sheet(1) and Sheet(2)) or just in Sheet(1); note while doing so entries from the dictionary that are written to Sheet(3) are deleted from the dictionary. The last loop writes out key/val pairs that remain in the dictionary. These are entries that are only in Sheet(2).
I've included the base code that currently runs to essentially pull out info for a specific product category based on a larger master listing (approx. 4000 lines by 36 columns). Previously this was not an issue, as the only codes listed and pulled out to individual sheets, were all is use; over time though, some of the older assigned product numbers are being discontinued and no longer in use. All I'm trying to do is modify the existing structure so that it first does a sweep through the master listing to verify whether or not any lines match the c.Value and d.Value - if there are no lines that meet the matching c.Value and d.Value criteria then it should just perform the action in the If statement inside the loop (ie. delete the old sheet, make a new one, and populate "G2" with a generic "item code not located" value); if any lines are found that meet the c and d.value criteria then it goes through the normal process.
Option Explicit
Sub Item()
CreateDeptReport "Item"
End Sub
Sub CreateDeptReport(Item As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet, shtPrevious As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim LastRow As Long
Dim arrColsToCopy
Dim c As Range, d As Range, e As Range, x As Integer
On Error GoTo Err_Execute
Application.ScreenUpdating = False
arrColsToCopy = Array(1, 8, 3, 7, 9, 10, 39, 19, 24, 25, 27, 29, 33, 34, 35)
Set shtMaster = ThisWorkbook.Sheets("CurrentMaster")
Set shtPrevious = ThisWorkbook.Sheets("PreviousMaster")
Set c = shtMaster.Range("AI5")
Set d = shtMaster.Range("H5")
Set e = shtMaster.Range("X5")
LCopyToRow = 11
Do
If c.Value = 2516 And d.Value = "37A" And Not e.Value = "T1" And Not e.Value = "T3" Then
If shtRpt Is Nothing Then
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Item").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtPrevious
Set shtRpt = ThisWorkbook.Sheets(shtPrevious.Index + 1)
shtRpt.Name = Item
Range("G2").Value = "Item"
Range("C3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
End If
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert Shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1
End If
Set c = c.Offset(1, 0)
Set d = d.Offset(1, 0)
Set e = e.Offset(1, 0)
Loop Until IsEmpty(c.Offset(0, -1))
ThisWorkbook.Worksheets("Item").Rows("10:10").Delete
LastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
If LastRow <> 0 Then
Rows(LastRow).EntireRow.Delete
End If
Range("A9").Select
Application.ScreenUpdating = True
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
It seems to me that you always want a new Worksheet for the Item.
So create the new worksheet first, then run the routine to find and fill the new worksheet with the records from the Master worksheet and use a variable (Dim blItmFound As Boolean) to flag when any record is found and at the end if there where no records found then enter in the new worksheet at G2 the generic string you want (see Rem Validate Records).
Please note that I changed "Item" for the value of the Variable Item and also changed this line:
Loop Until IsEmpty(c.Offset(0, -1))
for this:
Loop Until c.Value = Empty
for more details see IsEmpty Function
This is your code adjusted:
Sub CreateDeptReport(Item As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet, shtPrevious As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim LastRow As Long
Dim arrColsToCopy
Dim c As Range, d As Range, e As Range, x As Integer
Dim blItmFound As Boolean
arrColsToCopy = Array(1, 8, 3, 7, 9, 10, 39, 19, 24, 25, 27, 29, 33, 34, 35)
Application.ScreenUpdating = False
Set shtMaster = ThisWorkbook.Sheets("CurrentMaster")
Set shtPrevious = ThisWorkbook.Sheets("PreviousMaster")
Set c = shtMaster.Range("AI5")
Set d = shtMaster.Range("H5")
Set e = shtMaster.Range("X5")
Rem Delete Item Worksheet
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets(Item).Delete
Application.DisplayAlerts = True
On Error GoTo Err_Execute
Rem Add New Item Worksheet
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtPrevious
Set shtRpt = ThisWorkbook.Sheets(shtPrevious.Index + 1)
shtRpt.Name = Item
Range("G2").Value = Item
Range("C3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
Rem Get Records from Master
LCopyToRow = 11
blItmFound = False
Do
If c.Value = 2516 _
And d.Value = "37A" _
And Not e.Value = "T1" _
And Not e.Value = "T3" Then
blItmFound = True
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert Shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1
End If
Set c = c.Offset(1, 0)
Set d = d.Offset(1, 0)
Set e = e.Offset(1, 0)
Loop Until c.Value = Empty
Rem Validate Records
Select Case blItmFound
Case True
ThisWorkbook.Worksheets(Item).Rows("10:10").Delete
LastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
If LastRow <> 0 Then
Rows(LastRow).EntireRow.Delete
End If
Case False
ThisWorkbook.Worksheets(Item).Range("G2").Value = "Item: [" & Item & "] code not located"
End Select
Range("A9").Select
Application.ScreenUpdating = True
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Based on what I've read, it sounds like you should just search for the values in their respective columns beforehand. This is also assuming that if one of those conditions is false, you'll enter your new code. So you could do something like:
Set cRange = shtMaster.Columns("AI:AI")
Set dRange = shtMaster.Columns("H:H")
If cRange.Find(2516) Is Nothing Or dRange.Find("37A") Is Nothing Then
'do code when either one of these conditions is false
Else
'both values are found in their respective columns
'do existing code
EDIT:
Set rng = Range("AI:AI")
Set origCell = rng.Find(2516)
Set currCell = origCell
Do
Set currCell = rng.FindNext(currCell)
If shtMaster.Range("H" & currCell.Row).Value = "37A" Then
boolMatchingPair = True
Exit Do
End If
Loop While currCell.Row <> origCell.Row
If boolMatchingPair = True
'found match
Else
'no match
I'm trying to make a VBA script in an Excel document that loops through each line for an amount of time (column 3) and writes each of this line to the columns E, F, and G looking exactly like the line does in the Original input. In the end giving a total of 1050 lines with the example below.
The input looks like this, in Cell A, B and C, where column 1 is CompanyName, Column 2 is a CompanyNumber and column 3 is the amount.
CompanyName1 9910483 300
CompanyName2 9910477 250
CompanyName3 9910620 500
result:
CompanyName1 9910483 300
CompanyName1 9910483 300
CompanyName1 9910483 300
CompanyName1 9910483 300
CompanyName1 9910483 300
CompanyName1 9910483 300
etc to 300 lines, then next line item for amount times
The VBA code I made looks like this:
Sub DoWhileItemsAndAmount()
Dim counter As Integer
Dim rowCounter As Integer
Dim column1 As String
Dim column2 As String
Dim column3 As Integer
counter = 1
rowCounter = 1
Do While Cells(rowCounter, "C") Is Not Null
column1 = Cells(rowCounter, "A").Value
column2 = Cells(rowCounter, "B").Value
column3 = Cells(rowCounter, "C").Value
Do While counter < column3
Cells(counter, "E").Value = column1
Cells(counter, "F").Value = column2
Cells(counter, "G").Value = column3
counter = counter + 1
Loop
rowCounter = rowCounter + 1
Loop
End Sub
This results in error "Object required" running the macro. Telling nothing else like error codes etc. I like to believe that the script is in the right direction.
I know it doesn't sound logical, but a program we use expects this output as input.
Many thanks in advance.
Edit: i changed the code to this and now it works
`Sub DoWhileItemsAndAmount()
' Declare vars
Dim counter As Integer
Dim rowTeller As Integer
Dim savePos As Integer
Dim column1 As String
Dim column2 As String
Dim column3 As Integer
' Set vars
counter = 0
savePos = 1
rowCounter = 1
' set errorcatch
On Error GoTo Errorcatch
' do while cell C is Not Empty
Do While ActiveWorkbook.Sheets("Blad1").Cells(rowCounter, "C").Value <> ""
column1 = ActiveWorkbook.Sheets("Blad1").Cells(rowCounter, "A").Value
column2 = ActiveWorkbook.Sheets("Blad1").Cells(rowCounter, "B").Value
column3 = ActiveWorkbook.Sheets("Blad1").Cells(rowCounter, "C").Value
counter = 0
' do while teller smaller then value in field
Do While counter < column3
' add values to other fields incremental
ActiveWorkbook.Sheets("Blad1").Cells(savePos, "E").Value = column1
ActiveWorkbook.Sheets("Blad1").Cells(savePos, "F").Value = column2
ActiveWorkbook.Sheets("Blad1").Cells(savePos, "G").Value = column3
counter = counter + 1
savePos = savePos + 1
Loop
rowCounter = rowCounter + 1
Loop
Exit Sub
' show msgbox on error
Errorcatch:
MsgBox Err.Number & ": " & Err.Description
End Sub
`
This seems to work, had to build in a savePos to have it remember the line its at. the answer of iDevlop fixed the issue of the script not running.
To test if a cell is empty, you can use Range(xx) <> "" or cell(x,y)<>""
See this SO answer.
I am pretty new to VBA and I am having a bit of trouble writing a macro.
I want to search a value in a cell, on a column, that is on another worksheet and if it finds it, copy and paste the whole row where it is to another worksheet.
I pretty much have that one sorted but only doing 1 row. What I can't get to work is that after the first value has been read in "sheetTarget" say in cell T4, found in "sheetToSearch" say in A230 and pasted in row 1 in "sheetPaste" move and read the next cell T5 in "sheetTarget" and then keep repeating the process eg. find value of T5 on A350 and paste in row 2, T6 in A20 and paste on row 3, etc..
Sub copyE()
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
LCopyToRow = 1
Dim sheetPaste As String: sheetPaste = "Sheet11"
Dim sheetTarget As String: sheetTarget = "Sheet8"
Dim sheetToSearch As String: sheetToSearch = "Sheet1"
Dim x As String
Dim columnValue As String: columnValue = "T"
Dim rowValue As Integer: rowValue = 4
Dim LTargetRow As Long
Dim maxRowToTarget As Long: maxRowToTarget = 1000
Dim columnToSearch As String: columnToSearch = "A"
Dim iniRowToSearch As Integer: iniRowToSearch = 5
Dim LSearchRow As Long
Dim maxRowToSearch As Long: maxRowToSearch = 1000
For LTargetRow = rowValue To Sheets(sheetTarget).Rows.Count
Sheets(sheetTarget).Range(columValue & CStr(LTargetRow)).Value = x
For LSearchRow = iniRowToSearch To Sheets(sheetToSearch).Rows.Count
If Sheets(sheetToSearch).Range(columnToSearch & CStr(LSearchRow)).Value = x Then
Sheets(sheetToSearch).Rows(LSearchRow).copy
Sheets(sheetPaste).Rows(LCopyToRow).PasteSpecial Paste:=xlPasteValues
LCopyToRow = LCopyToRow + 1
End If
If (LSearchRow >= maxRowToSearch) Then
Exit For
End If
Next LSearchRow
If (LTargetRow >= maxRowToTarget) Then
Exit For
End If
Next LTargetRow
Application.CutCopyMode = False
Range("A3").Select
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
I will greatly appreciate any help.
This works for me and I believe it is what you are asking for.
Sub test()
Dim sheetPaste As Worksheet
Dim sheetTarget As Worksheet
Dim sheetToSearch As Worksheet
Dim x As String
Dim columnValue As String: columnValue = "T"
Dim rowValue As Integer: rowValue = 4
Dim LTargetRow As Long
Dim maxRowToTarget As Long: maxRowToTarget = 1000
Dim columnToSearch As String: columnToSearch = "A"
Dim iniRowToSearch As Integer: iniRowToSearch = 5
Dim LSearchRow As Long
Dim maxRowToSearch As Long: maxRowToSearch = 1000
LCopyToRow = 1
Set sheetPaste = ThisWorkbook.Worksheets("Sheet11")
Set sheetTarget = ThisWorkbook.Worksheets("Sheet8")
Set sheetToSearch = ThisWorkbook.Worksheets("Sheet1")
'MsgBox sheetTarget.Cells(Rows.Count, 20).End(xlUp).Row
'finds the last row with a value in it in column T of sheetTarget
For LTargetRow = rowValue To sheetTarget.Cells(Rows.Count, 20).End(xlUp).Row
'targetCell = columValue & CStr(LTargetRow)
'must set x = , not the value in the column = to x (which is not initialize to it is "")
If sheetTarget.Range(columnValue & CStr(LTargetRow)).Text <> "" Then
x = sheetTarget.Range(columnValue & CStr(LTargetRow)).Text
'finds the last row with a value in it in column A of sheetToSearch
For LSearchRow = iniRowToSearch To sheetToSearch.Cells(Rows.Count, 1).End(xlUp).Row
If sheetToSearch.Range(columnToSearch & CStr(LSearchRow)).Value = x Then
sheetToSearch.Rows(LSearchRow).Copy
sheetPaste.Rows(LCopyToRow).PasteSpecial Paste:=xlPasteValues
LCopyToRow = LCopyToRow + 1
Exit For
End If
'dont need this anymore now that we know that last row with data in it.
' If (LSearchRow >= maxRowToSearch) Then
' Exit For
' End If
Next LSearchRow
End If
'If (LTargetRow >= maxRowToTarget) Then
' Exit For
'End If
Next LTargetRow
'Sheets("data").Cells(Rows.Count, 1).End(xlUp).Row
End Sub
Some of the variables are not used anymore and if you have any questions feel free to ask.