'Declare Variables
Dim rng As Range
Dim AmQ As Worksheet, UpIss As Worksheet, QuMa As Worksheet
'Set your sheet names into variables for easier referencing
Set AmQ = Sheets("AMEND QUOTE")
Set UpIss = Sheets("UPISSUE")
For i = 7 To 57 '7 = Column H, 8 = Column G, etc.
'Set the address of the found value to the rng variable
Set rng = UpIss.Cells.Find(What:=AmQ.Cells(4, i).Value, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rng Is Nothing Then 'CHECK IF THE SEARCH TERM (FROM QUOTE SHEET) WAS FOUND IN THE TARGET SHEET (ESTIMATE)
If Not rng = "" Then 'CHECK IF THE SEARCH TERM WAS A ZERO LENGTH STRING
rng.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.Offset(14, 0)).Copy 'Copy the cell 41 rows down and 3 columns across
'QuMa.Cells(4, i).Offset(14, 0).PasteSpecial Paste:=xlPasteValues 'Paste into the cell 14 rows below the original search term in the QUOTE sheet
Sheets("QUOTE MASTER").Select
Range("C5000").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
'Copy Formats
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
'Copy Values
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
'Autofit
Columns("C:Q").EntireColumn.AutoFit
Application.CutCopyMode = False
ElseIf rng = "" Then 'EXIT SUB IF SEARCH TERM WAS A ZERO LENGTH STRING
'MsgBox "Work is Done"
Exit Sub
End If
ElseIf rng Is Nothing Then 'EXIT SUB IF SEARCH TERM WAS NOT FOUND IN THE TARGET SHEET
'MsgBox "Work is Done"
Exit Sub
End If
Set rng = Nothing
Next i 'Move to the next column across and loop
This is where I am getting my error:
rng.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.Offset(14, 0)).Copy
not able to copy in the loop.
Related
I want to go into a sheet and look for a value. If the value is there I want to grab the data in its row and paste transposed in another sheet. This function is working.
However, if the value in the column is not there I want to paste filler text into the column where the data would otherwise go.
I am getting a "Type Mismatch" error when I run the following code. What is going wrong/ how can I made this happen.
Dim c As Long
Windows("WBGrab").Activate '-> opens doc we want to look a
c = Sheets("SheetName").Columns(2).Find(What:="Commercial Income", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row
If c Is Nothing Then
Windows("WBPaste").Activate
Range("C2:C7").Value = "-"
Else
Sheets("SheetName").Range("C" & c & ":H" & c).Select '-> opens MBI DSCR sheet and copes naming & values
Selection.Copy '-> copies the selected area
Windows("WBPaste").Activate '-> opens back up the data lake
Sheets("Sheet1").Range("C" & 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=True
End Sub
If Find() fails to make a match then your code will error before getting to If c Is Nothing Then because of the .Row tagged onto the Find() line.
Something like this should work:
Sub Tester()
Dim c As Range, wsSrc As Worksheet, wsDest As Worksheet, cDest As Range
'set up source and destination sheets
Set wsSrc = Workbooks("WBGrab").Worksheets("SheetName") 'add the file extension to the name
Set wsDest = Workbooks("WBPaste").Worksheets("Sheet1")
Set c = wsSrc.Columns(2).Find(What:="Commercial Income", LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False)
Set cDest = wsDest.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) 'next paste destination. C2?
If c Is Nothing Then 'didn't make a match with Find() ?
cDest.Resize(1, 7).Value = "-" 'fill placeholders
Else
c.Offset(0, 1).Resize(1, 7).Copy 'got match - copy range
cDest.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End If
End Sub
The idea is to make a planning tool, based on a "database":
one row with dates, in the columns the needed transports,...
want to search on today and copy the non-blanks in that column to another sheet "dashboard"
want to copy the corresponding titles in the first columns of the "database" to the dashboard
Can't get it to work, searching around, and just don't get it, sorry. Novice in this...
2 questions:
how to solve error 91
how to dynamically select the right date (based on a loop through range) in a row with autofilter to get the data (non-blanks) in that column copied to another sheet?
Here's the code and the highlight where it gets stuck. If you want the file, let me know.
Sub Transportplan()
'
' Transportplan Macro
'
' Sneltoets: Ctrl+Shift+T
'ZET ALLES KLAAR VOOR NIEUWE PLANNING
'Ga naar planningsoverzicht en delete vorige planning
Sheets("NIEUW").Select
Columns("B:G").Select
Application.CutCopyMode = False
Application.CutCopyMode = False
Selection.ClearContents
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Ga naar data tab
Sheets("DATA").Select
'Alle filters uitdoen
ActiveSheet.ShowAllData
'Activate search criteria in column
ActiveSheet.Range("$A$4:$JN$196").AutoFilter Field:=5, Criteria1:=Array( _
"Transport", "Transport INGEPAKT: Fase + (PALLETnrs)", _
"Transport NIET ingepakt: Fase" & Chr(10) & "!!! RISICO NIET GELEVERD !!!", "Transport Retour" _
), Operator:=xlFilterValues
'--------------------------------------------------------
'START LOOP COPY PASTE SEQUENCE VOOR NIEUWE PLANNING
'1. Choose the date in the tab "Datums voor macro"
Sheets("Datums voor macro").Select
'Loop through dates
Dim rng As Range
Dim cell As Range
Set rng = Range("B4:B31")
For Each cell In rng
'------------------
'Search the date in the DATA tab
Sheets("DATA").Select
Cells.Find(What:="cell", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
'HOW CAN I GET FIELD 21 dynamically changed if the date changes (in row 4)
'If nothing that day, paste just the date
ActiveSheet.Range("$A$4:$JN$1000").AutoFilter Field:=21, Criteria1:="<>"
If (comboBox1.SelectedIndex = -1) Then
'Go to planning and paste that day
Sheets("NIEUW").Select
Range("G1").Select
ActiveCell.End(xlDown).Offset(1, 0).Select
ActiveRange = cell.Value
Else
'HOW CAN I GET FIELD 21 dynamically changed if the date changes (in row 4). I activated the macro through record and pressing Ctrl+F and pasting the date...
ActiveSheet.Range("$A$4:$JN$196").AutoFilter Field:=21, Criteria1:="<>"
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
'Go to planning and paste data
Sheets("NIEUW").Select
Range("G1").Select
ActiveCell.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
'Copy headers from DATA tab
Sheets("DATA").Select
Range("E4").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Application.CutCopyMode = False
Selection.Copy
'PASTE HEADERS in planning
Sheets("NIEUW").Select
'Search next empty cel to paste under previous data
Range("B1").Select
ActiveCell.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
End If
'END LOOP 1
'-----------------------------------
'RESTART LOOP
Next cell
End Sub
THis will give a runtime error if no match is found:
datadag.Find(What:="cell", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Use this pattern instead:
Dim f As Range
Set f = datadag.Find(What:="cell", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not f Is Nothing Then
'do something with f
Else
'handle "not found" case
End if
I need a loop to copy cells offset from a found value in SOURCE, (based on range in DESTINATION) to DESTINATION.
In this case I want to copy value from SOURCE ("K10") to DESTINATION ("G5"), after value ("E10") found in SOURCE based on value ("H5") in DESTINATION.
I need to search for all values in DESTINATION ("H:H").
Book_source.xlsx
Book_destination.xlsx
My recorded code:
Windows("Book_destination.xlsx").Activate
Dim rng As Variant
rng = Range("H5").Value
rng.Select
Selection.Copy
Application.WindowState = xlNormal
Windows("Book_source.xlsx").Activate
Cells.Find(What:=rng, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, 6).Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book_destination.xlsx").Activate
Range("G5").Select
ActiveSheet.Paste
I created this code and is working for me.
For anyone interested
Thanks all of you. :)
Enjoy, it's free!
I'm glad to share this.
Sub part_of_code()
Dim i As Integer
i = 2
'calling LastRow
Call LastRecord(LastRow)
For i = i To LastRow
On Error Resume Next
'Application.WindowState = xlNormal
Range("H" & i).Select
Selection.Copy
Dim rng As Variant
rng = Range("H" & i)
Workbooks("Book2.xlsx").Worksheets("Sheet1").Activate
Cells.Find(What:=rng, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, 6).Select
Application.CutCopyMode = False
Selection.Copy
Workbooks("Book1.xls").Worksheets("Sheet2").Activate
Range("H" & i).Offset(0, -1).Select
ActiveSheet.Paste
Next i
End Sub
Private Sub LastRecord(LastRow)
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
End Sub
I have the following code that Loops and searches through a range of sheets and copies and pastes to a "Blast List" sheet as it finds the correct values:
Sub CopySingle()
Dim wsfr As Worksheet
Dim wsl As Worksheet
Dim BlNumber As String
Dim BSStep As Long
Dim SI As String
Dim Srng As Range
Dim Nrng As Range
Dim Rrng As Range
Dim Brng As Range
Dim Arng As Range
Application.ScreenUpdating = False
BSStep = 1
Set Rrng = ThisWorkbook.Worksheets("Blast List").Range("A3", Range("A3").End(xlDown))
Set Srng = ThisWorkbook.Worksheets("Blast List").Range("E1:Q1")
For Each Brng In Rrng.Cells
For Each Nrng In Srng.Cells
On Error Resume Next
SI = Nrng.Value
BlNumber = CStr("Blasted " & BSStep)
Set wsfr = ThisWorkbook.Worksheets(CStr(BlNumber))
Set wsl = ThisWorkbook.Worksheets("Blast List")
wsfr.Select
Range("A1").Select
Cells.Find(What:=SI, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Selection.Copy
Sheets("Blast List").Select
Range("A1").Select
Cells.Find(What:=BlNumber, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).End(xlToRight).Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next Nrng
BSStep = BSStep + 1
Next Brng
Application.ScreenUpdating = True
End Sub
I am now trying to figure out how to adapt the code that if the value is not found, it will put the text "NO INFORMATION" in red in the cell.
Any and all help appreciated.
Regards
I have Sheet1 which is a form with fields where we enter data to be fed in the database (Sheet2).
Ideally, here's what I want it to do:
I want to search a field/record using the form contents in Sheet1, then search for that term on Sheet2. If it doesn't exist on Sheet2, give me a pop up message saying data doesn't exist.
If it does exist in Column A on Sheet2, then select the cell to the right of the result (Column B). Then paste that cell's contents in relevant fields on Sheet1
Then continue until all of the fields on Sheet1 has been searched for on Sheet2.
Here's the code I've been using. It only works for about 5 lines before it comes up with an error. Any help would be greatly appreciated.
I really don't want the MsgBox to pop up at all.
Sub abc()
Do Until IsEmpty(ActiveCell)
Dim MyString As String
MyString = ActiveCell
Sheets("Sheet2").Select
Set RangeObj = Cells.Find(What:=MyString, After:=ActiveCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If RangeObj Is Nothing Then MsgBox "Not Found" Else: RangeObj.Select
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(-1, -1).Select
Loop
End Sub
Please let me know what I'm doing wrong.
You were on the right path.. just a few amendments to how you were copying the data.
Option Explicit
Sub sheet2_lookup()
Dim strVal As String
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet, RangeObj As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Cells(1, 1).Activate '' amend this to your starting cell
While ActiveCell.Value2 <> ""
strVal = ActiveCell.Value2
Set RangeObj = ws2.Columns("A").Find(What:=strVal, After:=Cells(1, 1), LookIn:=xlValues)
If RangeObj Is Nothing Then
MsgBox "Not Found"
Else
ActiveCell.Offset(0, 1).Value2 = RangeObj.Offset(0, 1).Value2
End If
ActiveCell.Offset(1, 0).Activate
Wend
End Sub
Let me know how it goes.