DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Public Sub SayfaAc()
Dim i As Long, _
j As Integer, _
rng As Range, _
arr As Variant, _
shf As String, _
hata As String
Set rng = Sayfa2.Range("A1").CurrentRegion
arr = Sayfa1.Range("A1").CurrentRegion.Value
Application.ScreenUpdating = False
For i = 2 To UBound(arr, 1)
arr(i, 2) = BKH(CStr(arr(i, 2)))
arr(i, 3) = BKH(CStr(arr(i, 3)))
shf = arr(i, 2) & " " & arr(i, 3)
If SayfaVar(shf) = False Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = shf
rng.Copy ActiveSheet.Range("A4")
For j = 2 To 4
ActiveSheet.Cells(1, j - 1) = arr(1, j)
ActiveSheet.Cells(2, j - 1) = arr(i, j)
Next j
ActiveSheet.Cells.EntireColumn.AutoFit
Else
hata = hata & Chr(10) & shf
End If
Next i
Sayfa1.Select
Application.ScreenUpdating = True
If Len(hata) > 0 Then
MsgBox "SAYFASI OLUŞTURULAMAYANLAR LİSTESİ " & Chr(10) & hata
End If
End Sub
Function SayfaVar(SayfaAd As String) As Boolean
On Error Resume Next
SayfaVar = CBool(Len(Worksheets(SayfaAd).Name) > 0)
End Function
Function BKH(Sozcuk As String, Optional Tip As Integer = 2) As String
'Tip 1. Küçük Harf
' 2. Büyük Harf
' 3. Yazım Düzeni
Sozcuk = Application.WorksheetFunction.Trim(Sozcuk)
If Tip = 1 Then
BKH = Evaluate("=LOWER(" & """" & Sozcuk & """" & ")")
ElseIf Tip = 2 Then
BKH = Evaluate("=UPPER(" & """" & Sozcuk & """" & ")")
Else
BKH = Application.WorksheetFunction.Proper(Sozcuk)
End If
End Function