Word Belgesinden Excele Veri Alma Hakkında...

[yesimgurol]

Merhabalar;
Burada saygı değer hocalarımın saolsunlar ilgilenip yapmış olduğu makrolu excel listesine sadece 1 parametre eklemek istedim ama başarılı olamadım.Ekte bulunan klasör içindeki "LİSTEWORD" sayfasında açıklama yapmaya çalıştım.
Şimdiden okuyup ilgilendiğiniz için teşekkür eder,iyi çalışmalar dilerim.

 

[yesimgurol]

:-( Sanırım olmuyor.

 

[yesimgurol]

Merhabalar; elbetteki burada çözüm arayan arkadaşlar gibi bu tür sorunlar çok önem arz edebiliyor çoğu kez..İnanın benim içinde çok büyük önem arz ediyor.Umarım çözüm bulabilirim sorunum hakkında..

 

[hımmmmmmmm]

macro başka birine murat beye aitmiş...

farklı yazılımcılara ait macrolara ek yapmak her zaman risklidir...

ekdeki dosyayı incele...

(nOT: ...4. doc dosyasındaki kreatinin değerini kontrol için değiştirdim... bilgin olsun)

 

[nsertoglu]

Aşağıdaki kod değişimi ile yapılabilmektedir:

Sub wd_xl()
Sayfa1.Range("A3:Q14").ClearContents
'Application.ScreenUpdating = False
Set wd = CreateObject("word.Application")
wd.Visible = True
dosya = Dir(ThisWorkbook.Path & "\*.doc*")
Sat = 0
Wst = Array("Kurşun", "Çinko", "Nikel", "Alimunyum", "Civa", "Bakır", "Tungsten", "Kalay", "Magnezyum", "Kadmiyum", "Arsenik", "Provakasyon", "Kreatinin")
WSTknt = "Kurşun-Çinko-Nikel-Alimunyum-Civa-Bakır-Tungsten-Kalay-Magnezyum-Kadmiyum-Arsenik-Kreatinin"
Stn = Array("", 2, 9, 11, 3, 4, 5, 10, 8, 12, 13, 14, 15, 15)
krtr = Array("", 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
Do While dosya <> ""
On Error GoTo son
wd.Application.Documents.Open ThisWorkbook.Path & "\" & dosya
Set tbl = wd.ActiveDocument.Tables(1)
Sat = Cells(Rows.Count, 1).End(3).Row + 1
For x = 5 To tbl.Rows.Count - 1
deg = Trim(tbl.cell(x, 1).Range): deg = Left(deg, Len(deg) - 2)
If Len(deg) > 0 Then
If "Provakasyon" = Left(deg, 11) Then dmsa = LTrim(Split(tbl.cell(x, 3).Range, ":")(1))
If InStr(1, WSTknt, deg, vbTextCompare) > 0 Then
sira = WorksheetFunction.Match(deg, Wst, 0)
If deg = "Kreatinin" Then
veri = Trim(Left(tbl.cell(x + 1, 2).Range, Len(tbl.cell(x + 1, 2).Range) - 2))
Else
veri = Trim(Left(tbl.cell(x, 2).Range, Len(tbl.cell(x, 2).Range) - 2))
End If
If Len(veri) > 0 And IsNumeric(Replace(veri, ".", ",")) = True Then
If Round(Replace(veri, ".", ","), 2) > krtr(sira) Then
Cells(Sat, Stn(sira)) = veri
End If
End If
End If
End If
Next
If WorksheetFunction.CountA(Range("b" & Sat & ":k" & Sat)) > 0 Then
Cells(Sat, 1) = Sat - 2
Cells(Sat, 17) = dosya
Cells(Sat, "f") = Split(dmsa, " ")(0)
yas = Split(tbl.cell(2, 1).Range.Paragraphs(4), ":")(1)
Cells(Sat, "g") = Left(yas, Len(yas) - 1)
yas = Split(tbl.cell(2, 1).Range.Paragraphs(2), ":")(1)
Cells(Sat, "r") = Left(yas, Len(yas) - 1)
End If
son:
If Err.Number <> 0 Then Cells(Sat, 16) = "HATA"
wd.ActiveDocument.Close False
dosya = Dir
Loop
If Sat > 0 Then
wd.Application.Quit
End If
MsgBox "İşlem tamam", vbInformation, "m u r a t"
End Sub

 

[yesimgurol]

Sayın hmmmm ve nsertoglu,
İlginize ve güncellediğiniz makro için çok teşekkür ederim.Tam da istemiş olduğum gibi..İyi çalışmalar