PDA

View Full Version : [SOLVED] How to compare two Strings and do some find-copy-paste operation



Cinema
09-13-2016, 02:48 AM
Hi,

I want to compare the names on Sheet1 (listed vertically) with the names on Sheet2 (listed horizontally). On Sheet2 every Name has numbers listed below. If there is a match then the 2nd smallest number should be copied next to the Name on Sheet1.

Here is my code so far:


Sub Match()
Dim wb As Workbook
Dim i As Integer
Dim number As Integer
Dim find As String
Dim name As String
Dim a As Long
Set wb = ThisWorkbook
number = Sheets(Sheet2).Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To number
such = Sheets(Sheet2).Cells(6 + i, 4).Value
wert = Sheets(Sheet1).Cells(1, 1 + i).Value

If find = name Then

'--> go to Cell with the Header "name" and copy the 2nd smallest number in the column and paste it on Sheet1 next to "find"

End If
Next i



Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual



End Sub

Cinema
09-13-2016, 02:49 AM
Remark: "such" should be "find" and "wert" should be "name"

snb
09-13-2016, 03:31 AM
Kennst du http://www.office-loesung.de/p/viewforum.php?f=166 ?

jolivanes
09-13-2016, 05:18 PM
Oder
"wert" should be "value"

jolivanes
09-13-2016, 06:22 PM
Maybe

Sub So_Etwas()
Dim sh2 As Worksheet, lr As Long, c As Range, x As Long, y As Long
Set sh2 = Sheets("Sheet2")
lr = Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range("A1:A" & lr)
On Error Resume Next
x = sh2.Rows(1).Find(c.Value, , , 1, xlByColumns, xlPrevious).Column
With sh2
y = WorksheetFunction.Small(.Range(.Cells(2, x), .Cells(.Cells(.Rows.Count, x).End(xlUp).Row, x)), 2)
End With
On Error GoTo 0
c.Offset(, 1).Value = y
Next c
End Sub

SamT
09-13-2016, 06:26 PM
For your consideration with absolutely required changes

Sub Match()
Dim i As Long 'Integer :Row and column variables should be Long
Dim number As Long 'Integer
Dim Found As String 'find As String :Find is a VBA and Excel Function
Dim Nomen As String 'name As String :Name is an Excel Object and Property
Dim a As Long

number = Sheets(Sheet2).Cells(1, Columns.Count).End(xlToLeft).Column

'Add before code
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For i = 1 To number
such = Sheets(Sheet2).Cells(6 + i, 4).Value
wert = Sheets(Sheet1).Cells(1, 1 + i).Value

If found = nomen Then
'--> go to Cell with the Header "nomen" and copy the 2nd smallest number in the column and paste it on Sheet1 next to "find"
End If
Next i

'Reset after code
Application.ScreenUpdating = True 'False
Application.Calculation = xlCalculationAutomatic 'xlCalculationManual
End Sub

What are these lines for?

such = Sheets(Sheet2).Cells(6 + i, 4).Value
wert = Sheets(Sheet1).Cells(1, 1 + i).Value

SamT
09-13-2016, 06:28 PM
All my help files are on a broken computer, this is as far as I can get.

Sub Match_Code_Started()
Dim Cel As Range
Dim Found As Range
Dim Rw As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets("Sheet2")

For Each Cel In Sheets("Sheet1").Range(Cells(1, "A"), Cells(Rows.Count, "A").End(xlUp)) 'Uses Column a
Set Found = .Range("1:1").Find(Cel) 'uses Row 1

If Not Found Is Nothing Then
With .Columns(Found.Column)
'--> Cel.Offset(, 1) = Second smallest number


End With 'Found.Column
End If
Next Cel
End With 'Sheet2

Application.ScreenUpdating = True '
Application.Calculation = xlCalculationAutomatic
End Sub

Cinema
09-15-2016, 10:56 AM
Hi jolivanes,

that's it. you are great thank you.

Cinema
09-15-2016, 10:57 AM
Hi SamT,

thank you for your help and advice. I will Combine your help with jolivanes code. Thank you !

jolivanes
09-15-2016, 01:24 PM
Thank you for letting us know that you were helped with it.
Also, I am sure, from SamT

Cinema
09-16-2016, 01:33 AM
Hi jolivanes,

what does actually the command y = WorksheetFunction.Small(.Range(.Cells(2, x), .Cells(.Cells(.Rows.Count, x).End(xlUp).Row, x)), 2) does? Why do we have Range(.Cells(2 , x)) ?

jolivanes
09-16-2016, 05:45 AM
That line finds the 2nd lowest number in the used range below the found value.

Cinema
09-20-2016, 12:57 AM
thank you