Below is a macro we use to build a worksheet with a subset of a larger worksheet.
When the loop finds a match in our array of server names, it copies it over to the new worksheet.
I would like to add a new column to the new worksheet during the copy process. And after getting that working, I would like to fill this field by calling a function. We are trying to have a column that shows whether a server is a "critical" server. Simple y/n returns from a function that would look in an array of critical servers. I don't need the function, just how to add a column and fill it during the loop.
I will paste the big loop farther down, but here is the individual line of code that would copy over a range if found to a new worksheet. It is here I would like to add or copy one more column filled by a function:
Rcount = Rcount + 1
Source.Range("A" & Rng.Row & ":R" & Rng.Row).Copy NewSh.Range("A" & Rcount & ":R" & Rcount)
Here is the big loop for inquiring minds. It might be useful or at least prove this code is being used:
With Source.Range("A1:R9000")
'Find where the actual data we need starts
Set Rng = .Find(What:="Client", _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
intColorMatch = 0
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Set Rng = .FindNext(Rng)
If (Rng.Interior.Color = 13421772) Then
intColorMatch = intColorMatch + 1
End If
If (intColorMatch < 2) = False Then
StartRow = Rng.Row
Exit Do
End If
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Source.Range("A" & StartRow & ":R" & StartRow + 1).Copy NewSh.Range("A1:R2")
Rcount = 2
FirstAddress = 0
For I = LBound(MyArr) To UBound(MyArr)
'If you use LookIn:=xlValues it will also work with a
'formula cell that evaluates to "#"
'Note : I use xlPart in this example and not xlWhole
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
If Rng.Row >= StartRow Then
Rcount = Rcount + 1
Source.Range("A" & Rng.Row & ":R" & Rng.Row).Copy NewSh.Range("A" & Rcount & ":R" & Rcount)
' Use this if you only want to copy the value
' NewSh.Range("A" & Rcount).Value = Rng.Value
End If
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
If the "new" column that you are wanting to populate is after the end of your copied data, you aren't really adding a column - you are just populating an existing empty column.
If so, you can just say something like
NewSh.Cells(Rcount, "Q").Formula = "=whatever_formula_you_want"
(or use FormulaR1C1 if that is easier).
Or, if you only want to insert a value there (which you are calculating in your VBA code), it is just
NewSh.Cells(Rcount, "Q").Value = the_value_I_want
I am using the code below to sort a spreadsheet with various subtotals. On 5 out of 6 spreadsheets it works as expected. On the 6th spreadsheet I have encountered a problem with Excel ungrouping one row from a sub group. In the example below row 435 is removed from the rest of the group and row 436 has its height reduced to 0. I have looked at every cell in rows 435 and 436 and each matches the other rows in the group. After speaking with the users who would manually record a sorting macro they told me it sometimes happens to their spreadsheets as well. this macro works for the first 27 groups it has to sort. The subgroup I am having a problem with has 95 rows, other groups that have more rows do not have a problem.
Has anyone encountered this problem before and has anyone figured out how to deal with it?
The code I am using is below.
Sub mcrFindSortGroup()
Dim strFirstRow As String
Dim strLastRow As String
Dim LastCol As Integer
Dim c As Range
Dim strColumn As String
Application.DisplayAlerts = False
Application.EnableCancelKey = xlDisabled
Sheets("DCL Descriptions").Select
Range("H2:H2").Select
strColumn = ActiveCell
strColumn = strColumn - 1
Sheets("Sku Selling").Select
Columns("C:C").Select
For Each c In Range("DCL")
If c = "" Then GoTo DoneMsg
Cells(ActiveCell.Row, 1).Select
Range("C1:C15000").Activate
Selection.Find(What:=c, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
strFirstRow = ActiveCell.Row
Cells(ActiveCell.Row, 2).Select
If Cells(ActiveCell.Row + 1, 2) <> Cells(ActiveCell.Row, 2) Then
strLastRow = ActiveCell.Row
GoTo SkipSort
End If
Range(Selection, Selection.End(xlDown)).Select
strLastRow = ActiveCell.End(xlDown).Select
strLastRow = ActiveCell.Row
RowCount = (strLastRow - strFirstRow) + 1
Rows(strFirstRow & ":" & strLastRow).Select
ActiveWorkbook.Worksheets("Sku Selling").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sku Selling").Sort.SortFields.Add Key:=ActiveCell _
.Offset(0, strColumn).Range("A" & 1 & ":A" & RowCount) _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sku Selling").Sort
.SetRange ActiveCell.Range("A" & 1 & ":ZZ" & RowCount)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
SkipSort: ' the group has only 1 sku and does not need to be sorted
Next
DoneMsg:
MsgBox "Sorting Completed!", vbInformation, "Done"
Application.DisplayAlerts = True
Application.EnableCancelKey = xlErrorHandler
End Sub
These are before and after screen shots
Before:
After:
I am hoping someone can help me in my dilemma. Due to a system software limitation, I need to have all my code in one Macro.
1.) take Column Q which is a name in the format "last, first" and break it up using text to column (some names contain initials which is why I used text to column)
2.) include code to dismiss the message box that appears "Do you want to replace the contents of the destination cells?"
3.) delete all columns that are generated except the "last" & "first" name.
4.) concatenate the two columns so that they read Firstname Lastname
5.) auto fill down to the last row.
6.) copy paste special the values into an adjacent column and delete the old column with the function.
I tried recording the code but it seems that what I need can't be recorded and needs to be written.
Here's my shot at get those steps to work, pulled from code from my recorder as well as forums, and think I need a trained eye to sort through my mess:
Application.DisplayAlerts = False
Columns("Q:Q").Select
Selection.TextToColumns Destination:=Range("Q1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=True, Comma:=True, Space:=True, Other:=False, FieldInfo:= _
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _
True
Application.DisplayAlerts = False
Columns("U:U").Select
Selection.Delete Shift:=xlToLeft
Columns("S:T").Select
Selection.ClearContents
Range("S2").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-1], "" "", RC[-2])"
Range("S2").Select
Selection.AutoFill Destination:=Range("S2:500")
Range("S2:S42").Select
Columns("S:S").Select
Selection.Copy
Columns("T:T").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("T1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Lead Recruiter"
Columns("Q:S").Select
Selection.Delete Shift:=xlToLeft
Thanks to Ron, I was able to get the msg box to dismiss. Right now it's break at the line:
Selection.AutoFill Destination:=Range("S2:500")
How can I update this to Autofill to the last row? The data is in column Q. Any insight is greatly appreciated.
My Assumptions
Data is in Column Q
There is no data after Column Q
The results needs to be generated in Column R. If you want to replace the values in Column Q then see CODE 2.
Here is the shortest code that I could think of.
CODE 1
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in a column
lRow = .Range("Q" & .Rows.Count).End(xlUp).Row
'~~> Enter the formula in the complete column
.Range("R1:R" & lRow).Formula = "=IFERROR(MID(Q1,FIND("","",Q1,1)+2,FIND("" "",Q1,FIND("","",Q1,1)+2)-" & _
"(FIND("","",Q1,1)+2)),MID(Q1,FIND("","",Q1,1)+2,LEN(Q1)-FIND("","",Q1" & _
",1)+2+1)) & "" "" & LEFT(Q1,FIND("","",Q1,1)-1)"
'~~> Convert all formulas to values in one go
.Range("R1:R" & lRow).Value = .Range("R1:R" & lRow).Value
End With
End Sub
ScreenShot
CODE 2
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in a column
lRow = .Range("Q" & .Rows.Count).End(xlUp).Row
'~~> Enter the formula in the complete column
.Range("R1:R" & lRow).Formula = "=IFERROR(MID(Q1,FIND("","",Q1,1)+2,FIND("" "",Q1,FIND("","",Q1,1)+2)-" & _
"(FIND("","",Q1,1)+2)),MID(Q1,FIND("","",Q1,1)+2,LEN(Q1)-FIND("","",Q1" & _
",1)+2+1)) & "" "" & LEFT(Q1,FIND("","",Q1,1)-1)"
'~~> Convert all formulas to values in one go
.Range("R1:R" & lRow).Value = .Range("R1:R" & lRow).Value
'~~> Delete Col Q so R moves to Q
.Columns(17).Delete Shift:=xlToLeft
End With
End Sub
Followup from Comments
Is this what you are trying?
Sub FormatPushReport()
Dim ws As Worksheet
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
.Range("R:R,U:U").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("R1").Value = .Range("Q1").Value
.Range("V1").Value = .Range("U1").Value
'~~> Find the last row in a column
lRow = .Range("Q" & .Rows.Count).End(xlUp).Row
'~~> Enter the formula in the complete column
.Range("R2:R" & lRow).Formula = "=IFERROR(MID(Q2,FIND("","",Q2,1)+2,FIND("" "",Q2,FIND("","",Q2,1)+2)-" & _
"(FIND("","",Q2,1)+2)),MID(Q2,FIND("","",Q2,1)+2,LEN(Q2)-FIND("","",Q2" & _
",1)+2+1)) & "" "" & LEFT(Q2,FIND("","",Q2,1)-1)"
.Range("V2:V" & lRow).Formula = "=IFERROR(MID(U2,FIND("","",U2,1)+2,FIND("" "",U2,FIND("","",U2,1)+2)-" & _
"(FIND("","",U2,1)+2)),MID(U2,FIND("","",U2,1)+2,LEN(U2)-FIND("","",U2" & _
",1)+2+1)) & "" "" & LEFT(U2,FIND("","",U2,1)-1)"
'~~> Convert all formulas to values in one go
.Range("R2:R" & lRow).Value = .Range("R2:R" & lRow).Value
.Range("V2:V" & lRow).Value = .Range("V2:V" & lRow).Value
.Columns(18).Replace What:="#VALUE!", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
.Columns(22).Replace What:="#VALUE!", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
.Range("Q:Q,U:U").Delete Shift:=xlToLeft
End With
End Sub
Screenshot
I am trying to write a macro that will prompt the user to enter a value and do the following:
- Search for the value in column B and select the first cell where the value is found
- Return the correspondong value in column L and M of the selected cell's row within a message box
- Then once the user hits "ok", the macro will find and select the next cell in column B with the search criteria, and repeat the above steps
- Once all of the cells with the search criteria in column B have been searched and found, a message box will communicate that all matches have been found and close loop
Below is the code I have started out with, and being a beginner with VB, I can't figure out why my loop isn't working correctly... Please help!
Sub Macro1()
Dim response As String, FndRow As Long, NoMatch As Boolean, LastRow As Long
response = InputBox("Please enter the Column Name to find matching Source File Field Name.")
If response = "" Then Exit Sub
On Error Resume Next
Range("B5").Select
NoMatch = False
LastRow = 0
Do Until NoMatch = True
FndRow = Cells.Find(What:=response, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
If FndRow = 0 Then
MsgBox response & " could not be found."
NoMatch = True
ElseIf FndRow < LastRow Then
MsgBox "All " & response & " matches have been found."
NoMatch = True
Else
Range("B" & FndRow).Select
MsgBox "Source File Name: " & Range("L" & FndRow).Value & vbNewLine & "File Column Name: " & Range("M" & FndRow).Value
LastRow = FndRow
End If
Loop
End Sub
I would use a filter instead of a find loop:
Sub tgr()
Dim rngVis As Range
Dim VisCell As Range
Dim sFind As String
sFind = InputBox("Please enter the Column Name to find matching Source File Field Name.")
If Len(Trim(sFind)) = 0 Then Exit Sub 'Pressed cancel
Application.ScreenUpdating = False
With Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("B"))
.AutoFilter 1, sFind
On Error Resume Next
Set rngVis = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
End With
Application.ScreenUpdating = True
If rngVis Is Nothing Then
MsgBox sFind & " could not be found."
Else
For Each VisCell In rngVis.Cells
MsgBox "Source File Name: " & VisCell.Worksheet.Cells(VisCell.Row, "L").Text & vbNewLine & _
"File Column Name: " & VisCell.Worksheet.Cells(VisCell.Row, "M").Text
Next VisCell
End If
End Sub
your Find is acting strangely because you are looking for match 'horizontally'. You need to use SearchOrder:=xlByColumns
FndRow = Cells.Find(What:=response, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
I am completely new for VBA.
I have excel data sheet containing numbers and strings. I want to search for certain string say 'CYP' in column I then look for a cell of its row at column C and copy entire rows containing the string of cell C. I want to paste in sheet 2 of the same workbook and loop it again to look for remaining CYPs in column.
Would you help me on this please?
After the suggestion from pnuts, here is my macro code
Sub Macro1()
'
' Macro1 Macro
'
'
Columns("I:I").Select
Range("I729").Activate
Selection.Find(What:="cyp", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveWindow.SmallScroll Down:=5
Range("C749").Select
Selection.Copy
Columns("C:C").Select
Range("C734").Activate
Selection.Find(What:="EPT001TT0601C000151", After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
, MatchCase:=False, SearchFormat:=False).Activate
Rows("746:750").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
End Sub
In this code the CYP was found in I749, cell C749 was copied as string and first row in column C containing the same string was searched followed by copying of the entire row and 4 more followed by it then pasting in sheet2 of the same workbook.
What I wanted was to loop this action again and again upto the end of column I and repeat the same action.
Thank you!
I managed to solve the problem with the help of Trebor76 at Excelforum. Here I am giving solution in that way it might be helpful for some newbies like myself with similar problem.
Option Explicit
Sub Macro1()
'Written and assisted by Trebor76
'Copy an entire row from Sheet1 to Sheet2 for each unique matching item in Col. C if the text in Col. I contains the text 'CYP' (case sensitive)
'http://www.excelforum.com/excel-programming-vba-macros/962511-vba-for-searching-string-in-a-column-and-copy-rows-depending-on-string-in-adjacent-cell.html
Dim rngCell As Range
Dim objMyUniqueArray As Object
Dim lngMyArrayCounter As Long
Dim lngMyRow As Long
Dim varMyItem As Variant
Application.ScreenUpdating = False
Set objMyUniqueArray = CreateObject("Scripting.Dictionary")
For Each rngCell In Sheets("Sheet1").Range("I1:I" & Sheets("Sheet1").Range("I" & Rows.Count).End(xlUp).Row)
If InStr(rngCell, "CYP") > 0 Then
If Not objMyUniqueArray.Exists(Trim(Cells(rngCell.Row, "C"))) Then
lngMyArrayCounter = lngMyArrayCounter + 1
objMyUniqueArray.Add (Trim(Cells(rngCell.Row, "C"))), lngMyArrayCounter
varMyItem = Sheets("Sheet1").Cells(rngCell.Row, "C")
For lngMyRow = 1 To Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
If Sheets("Sheet1").Cells(lngMyRow, "C") = varMyItem Then
Rows(lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Next lngMyRow
End If
End If
Next rngCell
Set objMyUniqueArray = Nothing
Application.ScreenUpdating = True
MsgBox "All applicable rows have been copied.", vbInformation
End Sub
Cheers!