- Katılım
- 11 Ocak 2008
- Mesajlar
- 1,395
- Excel Vers. ve Dili
- Office 365 (Türkçe)
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
=YERİNEKOY(PARÇAAL(A2;BUL("(";A2)+1;255);")";"")
Sub Renklendir()
Dim Bs As Integer, _
Bt As Integer, _
Uz As Integer, _
Szc As String, _
c As Range, _
i As Long
Columns("A:A").Interior.Pattern = xlNone
For i = 2 To Cells(Rows.Count, "A").End(3).Row
Bs = InStr(Cells(i, "A"), "(") + 1
Bt = InStr(Cells(i, "A"), ")")
Uz = Bt - Bs
Szc = Mid(Cells(i, "A"), Bs, Uz)
Set c = Range("E:E").Find(Szc, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then Cells(i, "A").Interior.Color = c.Offset(0, 1).Interior.Color
Next i
End Sub
Üstadım. Bilgisayardan office çalıştırıken visual basice kodları yazmayı ALT-F11 le hallediliyordu. Şimdi. Bilgisayara yükleme yapamadığım için office online kullanıyorum. Bu kısa yollar onlinede yok nasıl yapayım.
Sub Renklendir()
Dim Szc As String, _
i As Long, _
c As Range, _
regExp, _
objMatches
Set regExp = CreateObject("VBScript.RegExp")
regExp.IgnoreCase = True
regExp.Global = True
regExp.Pattern = "\(([^\)]+)\)"
Application.ScreenUpdating = False
Range("A:A").Interior.Pattern = xlNone
For i = 2 To Cells(Rows.Count, "A").End(3).Row
If regExp.Test(Cells(i, "A").Text) Then
Set objMatches = regExp.Execute(Cells(i, "A"))
Szc = objMatches.Item(0).Submatches.Item(0)
Set c = Range("E:E").Find(Szc, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then Cells(i, "A").Interior.Color = c.Offset(0, 1).Interior.Color
End If
Next i
Set regExp = Nothing
Application.ScreenUpdating = True
End Sub
Sub SozcukAraRenklendir()
Dim Sh1 As Worksheet, _
Sh2 As Worksheet, _
c As Range, _
i As Long, _
Adr As String
Application.ScreenUpdating = False
Set Sh1 = Sheets("Sayfa1")
Set Sh2 = Sheets("Sayfa2")
Sh1.Range("A:A").Interior.Pattern = xlNone
For i = 2 To Sh2.Cells(Rows.Count, "E").End(3).Row
With Sh1.Range("A:A")
Set c = .Find(Sh2.Cells(i, "E"), LookIn:=xlValues)
If Not c Is Nothing Then
Adr = c.Address
Do
Sh1.Cells(c.Row, "A").Interior.Color = Sh2.Cells(i, "F").Interior.Color
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr
End If
End With
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır.....", vbInformation, "Excel.Web.Tr"
End Sub
Sn. @Necdet hocam çok teşekkür ederim, tam istediğim gibi oldu. Elinize sağlık. Hayırlı ramazanlar.
Bu konuda çok dağıldım. Formülü E3 e uyguluyorum. A2deKİ parantez içindeki kelime E3 e geliyor. Ancak koşullu biçimlendirme (mecburen libre office portable kullandığımdan) Biçim-Koşullara bağlı-Renk skalasında formülü uyguluyoruj, ancak burdan öte gidemiyorum.Kilitlendim.Kaldım.Aşağıdaki formülle parantez içinde veriyi bulabilirsiniz.
C++:=YERİNEKOY(PARÇAAL(A2;BUL("(";A2)+1;255);")";"")
Gerisini koşullu biçimlendirme-formül bölümü ile halledebilirsiniz.