Hücre verisine göre word dosyası açma

[acemi1985]

Üstadım Gönderdiğiniz dosyayı denedim Maşallah 5 saniyeyi bile bulmuyor.
Sanki ortaktan değil mi sorun.

 

[Asri]

Üstadım Gönderdiğiniz dosyayı denedim Maşallah 5 saniyeyi bile bulmuyor.
Sanki ortaktan değil mi sorun.

Evet ağ da dosya listesi okuma ile ilgi bir yavaşlık, aynı zamanda sizin pc de yavaş sanki. Liste sonrası link oluşturma da 1 dk dan fazlaydı.

 

[acemi1985]

Üstadım yolladığınız dosyayı ortağa klasöre kopyalayıp denedim sonuç inanılmaz 25 sn ben kırmızı yerleri değiştirdim.uzantı yı değiştirdim ve c sütunu yaptım a sütununu.birde sayfa adı değişti.yanlışım var mı ?

Sub link_olustur()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If WorksheetExists("Gecicixxxxx") Then Sheets("Gecicixxxxx").Delete
Set newsh = Sheets.Add(After:=Sheets(Sheets.Count))
newsh.Name = "Gecicixxxxx"

Dim myFile
Dim myDirectory
Dim counter
myDirectory = ActiveWorkbook.Path & "\"
myFile = Dir(myDirectory & "*.*")
counter = 0
Sheets("Gecicixxxxx").Columns("A:A").NumberFormat = "@"
Do While myFile <> ""
counter = counter + 1
With myFile
If InStr(myFile, " ") > 0 Then
Sheets("Gecicixxxxx").Cells(counter, 1) = Mid(myFile, 1, InStr(myFile, " ") - 1)
Sheets("Gecicixxxxx").Cells(counter, 2) = myDirectory & myFile
End If
End With
myFile = Dir()
Loop

Sheets("Sayfa1").Select
sonsatir = Cells(Rows.Count, "A").End(3).Row
sonsatir2 = Sheets("Gecicixxxxx").Cells(Rows.Count, "A").End(3).Row

For i = 2 To sonsatir
aranan = Cells(i, "A").Value
Set k = Sheets("Gecicixxxxx").Range("A1:A" & sonsatir2).Find(aranan, , xlValues, xlWhole)
satir = 0
If k Is Nothing Then
Cells(i, "A").Hyperlinks.Delete
Cells(i, "A").Font.Underline = xlUnderlineStyleNone
Cells(i, "A").Font.ThemeColor = xlThemeColorLight1
Cells(i, "A").HorizontalAlignment = xlLeft
Cells(i, "A").VerticalAlignment = xlBottom
Else
satir = k.Row
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, "A"), Address:=Sheets("Gecicixxxxx").Cells(satir, "B"), TextToDisplay:=aranan
End If
Next i

If WorksheetExists("Gecicixxxxx") Then Sheets("Gecicixxxxx").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[acemi1985]

Hocam hız konusu çözüldü çok mutluyum excelde sıkıntı varmış 14 mb lık formullerle dolu bir excelde deniyodum sorun oymuş başka bir excelde, hatta kendi çalışmamda denedim çözüldü
Peki yıl konusunu nasıl yapabiliriz Üstadım?

 

[acemi1985]

Sayın Asri Yıl Klasörü hakkında hiç şansım yok mu?

 

[Asri]

Sayın Asri Yıl Klasörü hakkında hiç şansım yok mu?

Yıl konusundna ben birşey anlamadım.

Eski yılları başka bir kolona taşıyın demiştim. Böylece progeam onları değiştirmez.

 

[acemi1985]

Teşekkür ederim Sayın Asri Harika bir Makro paylaştınız benimle hakkınızı helal edin.
Elinize Emeğinize Sağlık.