i look for a Code in VBA to look after Strings (called "Setup") in sheet2 and copy the String under "Setup" into sheet1 in cell A1.
I have a not working code from a recorded macro:
Sub FindString()
Cells.Find(What:="Setup", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Range("I8").Select
Selection.Copy
Sheets("Tabelle1").Select
ActiveSheet.Paste
End Sub
If i change that String, it Shows me error 91...
Try this
Sub FindString()
Sheets("Sheet2").Activate
Cells.Find(What:="Setup", LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Select
Selection.Copy
Sheets("Sheet1").Select
Range("A1").Select
ActiveSheet.Paste
End Sub
'--------------------------------------------------------------------------------------
' Specify the string to find in sheet1 B1 cell
Sub FindString2()
Sheets("Sheet2").Activate
Cells.Find(What:=Sheets("Sheet1").Range("B1").Value, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Select
Selection.Copy
Sheets("Sheet1").Select
Range("A1").Select
ActiveSheet.Paste
End Sub
Similar to #Punith's answer, except you don't need to change sheets.
Option Explicit
Sub find_string()
Const strLookup As String = "Setup"
Dim wb As Workbook, find_ws As Worksheet, to_ws As Worksheet, rngFound As Range
Set wb = ThisWorkbook
Set find_ws = wb.Sheets("find")
Set to_ws = wb.Sheets("to")
Set rngFound = find_ws.Cells.Find(What:=strLookup, LookIn:=xlValues, LookAt:=xlWhole).Offset(1, 0)
to_ws.Range("A1").Value = rngFound.Value
End Sub
Related
I'm trying to loop through every worksheet in my file and if certain word is found in workbook delete that cell with other eleven cells below.
I give up. My code doesn't work. Can't figure out why.
Can someone help me please?
Sub forEachWs()
Dim ws As Worksheet
Dim find As Range
For Each ws In ActiveWorkbook.Worksheets
Sheets(ws).Select
Set find = Cells.find(What:="nieusprawiedliwiona", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False)
If Not find Is Nothing Then find.Activate
Range(Selection, Selection.Offset(11, 0)).Select
Selection.EntireRow.Delete
Next ws
End Sub
Ok. I got it working.
Sub forEachWs()
Dim ws As Worksheet
Dim find As Range
For Each ws In Worksheets
MsgBox (ws.Name)
ws.Select
Set find = Cells.find(What:="nieusprawiedliwiona", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False)
If Not find Is Nothing Then find.Activate
Range(Selection, Selection.Offset(11, 0)).Select
Selection.EntireRow.Delete
Next ws
End Sub
Try without the select/activate:
Sub forEachWs()
Dim ws As Worksheet
Dim find As Range
For Each ws In ActiveWorkbook.Worksheets
Set find = ws.Cells.find(What:="nieusprawiedliwiona", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False)
If Not find Is Nothing Then find.Resize(12,1).EntireRow.Delete
Next ws
End Sub
Sub MisRec()
Dim ws As Worksheet
For Each ws In Worksheets
Cells.Find(What:="abc", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
ActiveCell.Offset(-2, 0).Select
Range(ActiveCell, "A2").Select
Selection.EntireRow.Delete
Next ws
End Sub
This is the code I have now which is not working fine for me.
You need to be more explicit about where you're searching, and also you should test that something was found before proceeding:
Sub MisRec()
Dim ws As Worksheet, f As Range
For Each ws In Worksheets
Set f = ws.Cells.Find(What:="abc", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:= xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not f Is Nothing then
ws.Range(f.Offset(-2, 0), ws.Range("A2")).EntireRow.Delete
End If
Next ws
End Sub
Column A to H has data with some blanks in between. I want to find "ABC" in column A and then select 2 rows above - this will be my ActiveCell.
I want to delete rows in between ActiveCell to Row2 (Active Cell is Dynamic)
Sub format()
Cells.Find(What:="abc", _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:= xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False).Activate
ActiveCell.Offset(-2, 0).Select
Range(Selection, ActiveCell, A2).Select
End Sub
The code will do the job for you:
Sub format()
Dim rng As Range
Set rng = Cells.Find(What:="abc", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
rng.Offset(-2, 0).Select
Range(Cells(Selection.Row, 1), Cells(2, 1)).Select
'Selection.EntireRow.Delete
End Sub
Currently I have commented out the last line which will delete the Rows you want. uncomment it, but first be sure that's what you want to delete.
For Range please try:
(ActiveCell, "A2").Select
I am writing an Excel macro that needs to find specific text Client Remittance Details and then select and cut to the end of the sheet and then paste on another tab. The text can be in on a different row for each different workbook. The macro always writes a specific cell reference so it errors on the next file. Here is the section of the macro that seems to be the error.
Cells.Find(What:="Client Remittance Details", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
Range("A12").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Cut
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Your Range("A12").Select is ruining your find. This:
Sub luxation()
Dim r1 As Range, rCopy As Range, rPaste As Range
Set r1 = Cells.Find(What:="Client Remittance Details", After:=Cells(1, 1), LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False)
Set rCopy = Range(r1, Cells.SpecialCells(xlCellTypeLastCell))
Sheets.Add After:=ActiveSheet
Set rPaste = Range("A1")
rCopy.Copy rPaste
End Sub
This sets rPaste to cell A1 on the newly added sheet.
So I have two excel documents.
One to take data from (RESULT.xlsm).
Another to insert data into (Summary.xls).
What I want is the adjacent cell values next to the hightlighted names to get inserted into Summary.xls under the respective columns. So I tried recording a macro but what happens is only the first record gets inserted.
Since only two links are allowed for me, i put it all in one picture:
http://i50.tinypic.com/9veihl.png
Note: There are multiple records in RESULT.xlsm and the screenshot shows just one.
I would like help on how I can extract data from all the set of records and insert in Summary.xlsx
Here's the recorded macro code:
Sub Summ()
Workbooks.Open Filename:="Summary.xlsx"
Windows.Arrange ArrangeStyle:=xlVertical
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Air System Name", After:=ActiveCell, LookIn:=xlFormulas _
, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B10").Select
Selection.Copy
Windows("Summary.xlsx").Activate
Range("A5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Floor Area", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B14").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("B5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Total coil load", After:=ActiveCell, LookIn:=xlFormulas _
, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B27").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("C5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Sensible coil load", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
Range("B28").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("D5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Max block L/s", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B30").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("E5").Select
ActiveSheet.Paste
Range("A6").Select
End Sub
I've also attached the excel files at mediafire:
Excel files
Please do help.
Thanks alot:)
So I looked up at alot of resources and tried to follow what #Tim Williams told me to and stumbled across this page (the last part): https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/text-functions/column-sets-to-rows
They had a solution almost close to my problem, so I made a few modifications and I'm done:D
Note: This is within the same document, different sheets.
The code of it:
Dim LR As Long, NR As Long, Rw As Long
Dim wsData As Worksheet, wsOUT As Worksheet
Dim HdrCol As Range, Hdr As String, strRESET As String
Set wsData = Sheets("Sheet1") 'source data
Set wsOUT = Sheets("Sheet2") 'output sheet
strRESET = " Air System Name " 'this value will cause the record row to increment
LR = wsData.Range("A" & Rows.Count).End(xlUp).Row
'end of incoming data
Set HdrCol = wsOUT.Range("1:1").Find(strRESET, _
LookIn:=xlValues, LookAt:=xlWhole) 'find the reset category column
If HdrCol Is Nothing Then
MsgBox "The key string '" & strRESET & _
"' could not be found on the output sheet."
Exit Sub
End If
NR = wsOUT.Cells(Rows.Count, HdrCol.Column) _
.End(xlUp).Row 'current output end of data
Set HdrCol = Nothing
On Error Resume Next
For Rw = 1 To LR
Hdr = wsData.Range("A" & Rw).Value
If (Hdr = " Air System Name ") Then
NR = NR + 1
End If
If Hdr <> "" Then
Set HdrCol = wsOUT.Range("1:1").Find(Hdr, _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not HdrCol Is Nothing Then
wsOUT.Cells(NR, HdrCol.Column).Value _
= wsData.Range("B" & Rw).Value
Set HdrCol = Nothing
End If
End If
Next Rw
The only little problem is the space. In my excel document, my report has trailing and leading spaces, and this doesn't match with my sheet2 columns headers, I kind of temporarily fixed it, since I looked around and couldn't find a way to automatically trim all the space from the whole column.
So that's it:)