köprü kopyalama işlemi (1000 den fazla köprünün urlsini nasıl alırım kopyalarım)

[gencwebciadam]

hayırlı geceler

1000 den fazla kayıt var elimde ve bazı sutunlarda köprü var. köprüyü direk kopyalayınca metinde ne yazıyorsa o geliyor aslında bana linki gerek.

tüm o linkleri nasıl kopyalarım.

yapmak istediğim şey şu. excel den kopyaladıklarımı access e aktarmak ama köprü linkleri gelmiyor? almanın bi yolu yokmu yoksa tek tek mi alabilirim

 

[Ömer BARAN]

Makro ile mümkündür.
1'inci satırın başlık satırı, köprü içeren hücrelerin A sütununda olduğu ve
bunlardaki köprü metinlerini B sütununa alacağınız varsayımıyla
aşağıdaki kodu sayfanın kod bölümüne yapıştırın ve çalıştırın.
Köprü metinleri B sütununa yazılacaktır.

Sub köprüal()
son = Range("A65536").End(3).Row

For i = 2 To son
    Range("B" & i) = Range("A" & i).Hyperlinks(1).Address
Next

End Sub

Sonra B sütunundan istediğiniz yere alabilirsiniz.

 

[gencwebciadam]

Sub köprüal()
son = Range("A65536").End(3).Row

For i = 102 To son
Range("N" & i) = Range("E" & i).Hyperlinks(1).Address
Next

End Sub

hocam köprüler e satırında
n satırı boş oraya aktarmak için böyle düzlettim ancak çalışmadı

E nin 4 satırından başlıyor hocam

nasıl yapabilirim

 

[Ömer BARAN]

"son" diye başlayan satırı silin,
For i = 102 To son yerine For i = 4 To ......
Noktaların yerine son köprü kaçıncı satırda ise o satır numarasını yazın.

 

[gencwebciadam]

Sub köprüal()


For i = 4 To 1988
Range("N" & i) = Range("E" & i).Hyperlinks(1).Address

Next

End Sub

kodum bu şekilde hocam ancak runtime error '9' hatası veriyor

 

[Ömer BARAN]

Şu an bilgisayar başında değilim, cep telefonundan yazıyorum.
İsterseniz örnek verinizi bir dosyaya kayydedip burası gibi bir paylaşım sitesine yükleyin ve oradan alacağınız erişim link'ini burada paylaşırsanız ben olmasam da başka bir üye destek verecektir.

 

[gencwebciadam]

http://dosya.web.tr/Kp1yDR

bu linke yükledim hocam dosyayı

afiş linklerini boş bir sütuna aktarmak istiyorum hocam

 

[karotis]

Şunu bir deneyebilir misiniz?

Sub hyperlink()

Dim t%, i%
Dim wa As Workbook
Dim s1 As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableCancelKey = xlDisabled

Set wa = ThisWorkbook
Set s1 = wa.Sheets("1080P DUAL ( TR - EN Ses )") '("sayfa ismi veya numarası")

t = s1.Cells(Rows.Count, 2).End(xlUp).Row
On Error Resume Next
For i = 5 To t
s1.Cells(i, 14) = s1.Cells(i, 5).Hyperlinks(1).Address '5 E sutununun numarası 14 ise N sutununun
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableCancelKey = True
End Sub

 

[gencwebciadam]

hocam sizin kodunuzla yaptım ancak bazı resimler aynı oldu koddan kaynaklanıyor olamaz değil mi ?

 

[karotis]

Kodda bir sorun olduğunu düşünmüyorum;linklere tıklarsanız aynı resimlerin açıldığını göreceksiniz, iyi günler dilerim.

 

[gencwebciadam]

ilk 10 link karışmıştı excel in yedeği vardı ordan girdim yaptım oldu hocam Allah sizden razı olsun

 

[Ömer BARAN]

Anlaşılan aralarda boşluklar varmış.
Benim gönderdiğim kodun en başına, ( For 'dan önce);
On Error Resume Next
şeklinde bir satır eklerseniz sorun kalmayacaktır.

 

[gencwebciadam]

hocam veriyi çektim access e ancak dediğiniz gibi galiba linklerde boşluklar var listeletirken çekmiyor resimleri göstermiyor.

sizin verdiğiniz kodda nasıl yapabilirim

 

[Ömer BARAN]

Merhaba.
Sayfaya 1 düğme/şekil/metin kutusu ekleyin ve aşağıdaki kodu
Module1 içine yapıştırın. Eklediğiniz düğmeye sağ klik "Makro ata" -> köprüal'ı
seçin işlemi onaylayın. Ardından düğmeye tıklayın.

Linklerin metnini elde etmiş olursunuz.

Linkleri aktif kullanmak istiyorsanız kod metnindeki;
başında tek tırnak olan send key diye başlayan satırların
başındaki tek tırnakları sildikten sonra çılıştırın.

[SIZE="2"]Sub köprüal()
son = Range("E65536").End(3).Row
On Error Resume Next

ApplicationScreenUpdating = False

Range("N:N").ClearContents

For i = 5 To son
    Range("N" & i) = Range("E" & i).Hyperlinks(1).Address
[/SIZE]
[B][COLOR="Red"]'[/COLOR]SendKeys "{F2}", True[/B]
[B][COLOR="Red"]'[/COLOR]SendKeys "{ENTER}", True[/B]
[SIZE="2"]
Next
ApplicationScreenUpdating = True

End Sub
[/SIZE]