Sayın Ustalar Kolay gelsin.
excel konususunda pek iyi olmama rağmen bulduğum kodlarla birşeyler yapmaya çalışıyorum. Amacım bir butona atanmış emirle klasördeki word dosyalarını sırayla açtırmak, word dosyalarındaki yer imlerine excel sayfasından veri aldırmak ve farklı kaydetmek. Ancak açılan dosyalarda istediğim yerlerin dışında bir aralığa veri alıyor(tüm verier bu alanda dönüyor) konu hakkında nasıl bir yol izlenebilir? Yardım edebilirseniz sevinirim zira epeydir uğraşmama rağmen tıkanıp kaldım. Saygılarımla...
yapmaya çalıştıım olayla ilili yapabildiklerim aşağıdadır.
Asf = ThisWorkbook.Path
yol = ThisWorkbook.Path & "\" & "atamalar"
dyol = Asf & "\" & ComboBox1.Value
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")
For Each dosya In fL.GetFolder(yol).Files
uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_Adi = fL.GetBaseName(dosya)
If uzanti = "doc" Or uzanti = "docx" Then
Dim wd As Word.Application
'Dim wrddoc As Word.Document
Set wd = CreateObject("Word.Application")
wd.Documents.Open (dosya)
wd.Visible = True
'''''''''''''''''''''''''''''''''
For Each bak In Range("b1:b" & WorksheetFunction.CountA(Range("A1:A65000")))
If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then
Satir = bak.Offset(0, 0).Value
'Deg = Array("", "ÇALTEM", "ÇALTEMTC", "ÇALTEMTR", "ÇALTEM2", "VEK", "SGK", "PROJEİSMİ", "PROJE_İSMİ", "İGU", "FİRMAADI", "FİRMA_ADI")
'Deg = Array("", "c", "d", "f", "g", "h", "ı", "k", "l", "n", "o", "q", "r", "s", "t", "u", "v", "w", "x", "Y", "z")
Deg = Array("", "ÇALTEM", "ÇALTEMTC", "ÇALTEMTR", "DEST", "DESTTC", "DESTTR", "FRM", "İŞV", "PRJ", "SGK", , "ŞEF", "ŞEFTC", "VEK", "VEKTC", "VEKTR") 'Yer imlerinin bulunduğu dizi
''''''''''''''''''''''''''''''''''''''''
If dosya = "FR-13 ÇALIŞAN TEMSİLCİSİ ATAMA" Then
Deg = Array("", "ÇALTEM", "ÇALTEMTC", "ÇALTEMTR", "ÇALTEM2", "VEK", "SGK", "PROJEİSMİ", "PROJE_İSMİ""FİRMAADI""FİRMA_ADI")
wd.Selection.GoTo What:=wdGoToBookmark, Name:=Deg(x) 'Yer imine ulaşmayı sağlayan komut
nnnnnnnnnnnnwd.Selection = (bak.Offset(0, x)) 'Döngü numarasındaki sütunda bulunan bilgiyi ilgili yere alan sat
ElseIf dosya = "FR-08 İŞ GÜVENLİĞİ UZMANI ATAMA" Then
Deg = Array("", "VEK", "SGK", "PROJEİSMİ", "PROJE_İSMİ""İGU", "FİRMAADI""FİRMA_ADI")
wd.Selection.GoTo What:=wdGoToBookmark, Name:=Deg(x) 'Yer imine ulaşmayı sağlayan komut
nnnnnnnnnnnnwd.Selection = (bak.Offset(0, x)) 'Döngü numarasındaki sütunda bulunan bilgiyi ilgili yere alan sat
ElseIf dosya = "FR-11 ŞANTİYE ŞEFİ ATAMA" Then
Deg = Array("", "VEK", "SGK", "PROJEİSMİ", "PROJE_İSMİ", "FİRMAADI""FİRMA_ADI", "İŞV", "VEK", "VEKTC", "VEKTR")
wd.Selection.GoTo What:=wdGoToBookmark, Name:=Deg(x) 'Yer imine ulaşmayı sağlayan komut
nnnnnnnnnnnnwd.Selection = (bak.Offset(0, x)) 'Döngü numarasındaki sütunda bulunan bilgiyi ilgili yere alan sat
End If
On Error Resume Next
For x = 1 To UBound(Deg) 'Yer imi sayısı kadar döngü
wd.Selection.GoTo What:=wdGoToBookmark, Name:=Deg(x) 'Yer imine ulaşmayı sağlayan komut
'hcr = (bak.Offset(0, x + 1))
'If x = 1 Then hcr = (bak.Offset(0, x)) & " " & (bak.Offset(0, x + 1))
'wd.Selection = hcr
wd.Selection = (bak.Offset(0, x)) 'Döngü numarasındaki sütunda bulunan bilgiyi ilgili yere alan sat
Next
End If
Next
Set wrddoc = wd.ActiveDocument
wrddoc.SaveAs2 dyol & "\" & dosya_Adi & ".docx" 'sablon dosyasını yazdır olarak kaydetmeye yareyen satır
Application.ScreenUpdating = False
wrddoc.Application.Quit
'MsgBox "aktarım tamam"
End If
Next
End Sub
excel konususunda pek iyi olmama rağmen bulduğum kodlarla birşeyler yapmaya çalışıyorum. Amacım bir butona atanmış emirle klasördeki word dosyalarını sırayla açtırmak, word dosyalarındaki yer imlerine excel sayfasından veri aldırmak ve farklı kaydetmek. Ancak açılan dosyalarda istediğim yerlerin dışında bir aralığa veri alıyor(tüm verier bu alanda dönüyor) konu hakkında nasıl bir yol izlenebilir? Yardım edebilirseniz sevinirim zira epeydir uğraşmama rağmen tıkanıp kaldım. Saygılarımla...
yapmaya çalıştıım olayla ilili yapabildiklerim aşağıdadır.
Asf = ThisWorkbook.Path
yol = ThisWorkbook.Path & "\" & "atamalar"
dyol = Asf & "\" & ComboBox1.Value
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")
For Each dosya In fL.GetFolder(yol).Files
uzanti = LCase(fL.GetExtensionName(dosya.Name))
dosya_Adi = fL.GetBaseName(dosya)
If uzanti = "doc" Or uzanti = "docx" Then
Dim wd As Word.Application
'Dim wrddoc As Word.Document
Set wd = CreateObject("Word.Application")
wd.Documents.Open (dosya)
wd.Visible = True
'''''''''''''''''''''''''''''''''
For Each bak In Range("b1:b" & WorksheetFunction.CountA(Range("A1:A65000")))
If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox1.Value, vbUpperCase) Then
Satir = bak.Offset(0, 0).Value
'Deg = Array("", "ÇALTEM", "ÇALTEMTC", "ÇALTEMTR", "ÇALTEM2", "VEK", "SGK", "PROJEİSMİ", "PROJE_İSMİ", "İGU", "FİRMAADI", "FİRMA_ADI")
'Deg = Array("", "c", "d", "f", "g", "h", "ı", "k", "l", "n", "o", "q", "r", "s", "t", "u", "v", "w", "x", "Y", "z")
Deg = Array("", "ÇALTEM", "ÇALTEMTC", "ÇALTEMTR", "DEST", "DESTTC", "DESTTR", "FRM", "İŞV", "PRJ", "SGK", , "ŞEF", "ŞEFTC", "VEK", "VEKTC", "VEKTR") 'Yer imlerinin bulunduğu dizi
''''''''''''''''''''''''''''''''''''''''
If dosya = "FR-13 ÇALIŞAN TEMSİLCİSİ ATAMA" Then
Deg = Array("", "ÇALTEM", "ÇALTEMTC", "ÇALTEMTR", "ÇALTEM2", "VEK", "SGK", "PROJEİSMİ", "PROJE_İSMİ""FİRMAADI""FİRMA_ADI")
wd.Selection.GoTo What:=wdGoToBookmark, Name:=Deg(x) 'Yer imine ulaşmayı sağlayan komut
nnnnnnnnnnnnwd.Selection = (bak.Offset(0, x)) 'Döngü numarasındaki sütunda bulunan bilgiyi ilgili yere alan sat
ElseIf dosya = "FR-08 İŞ GÜVENLİĞİ UZMANI ATAMA" Then
Deg = Array("", "VEK", "SGK", "PROJEİSMİ", "PROJE_İSMİ""İGU", "FİRMAADI""FİRMA_ADI")
wd.Selection.GoTo What:=wdGoToBookmark, Name:=Deg(x) 'Yer imine ulaşmayı sağlayan komut
nnnnnnnnnnnnwd.Selection = (bak.Offset(0, x)) 'Döngü numarasındaki sütunda bulunan bilgiyi ilgili yere alan sat
ElseIf dosya = "FR-11 ŞANTİYE ŞEFİ ATAMA" Then
Deg = Array("", "VEK", "SGK", "PROJEİSMİ", "PROJE_İSMİ", "FİRMAADI""FİRMA_ADI", "İŞV", "VEK", "VEKTC", "VEKTR")
wd.Selection.GoTo What:=wdGoToBookmark, Name:=Deg(x) 'Yer imine ulaşmayı sağlayan komut
nnnnnnnnnnnnwd.Selection = (bak.Offset(0, x)) 'Döngü numarasındaki sütunda bulunan bilgiyi ilgili yere alan sat
End If
On Error Resume Next
For x = 1 To UBound(Deg) 'Yer imi sayısı kadar döngü
wd.Selection.GoTo What:=wdGoToBookmark, Name:=Deg(x) 'Yer imine ulaşmayı sağlayan komut
'hcr = (bak.Offset(0, x + 1))
'If x = 1 Then hcr = (bak.Offset(0, x)) & " " & (bak.Offset(0, x + 1))
'wd.Selection = hcr
wd.Selection = (bak.Offset(0, x)) 'Döngü numarasındaki sütunda bulunan bilgiyi ilgili yere alan sat
Next
End If
Next
Set wrddoc = wd.ActiveDocument
wrddoc.SaveAs2 dyol & "\" & dosya_Adi & ".docx" 'sablon dosyasını yazdır olarak kaydetmeye yareyen satır
Application.ScreenUpdating = False
wrddoc.Application.Quit
'MsgBox "aktarım tamam"
End If
Next
End Sub