wordden excele tablo makroları

[modoste]

merhaba sayın hocalarım
forumda arattım makrolarla ilgili ancak yanıt bulamadım o yüzden buraya sormak istiyorum

yapılacak makro çalıştığında; word dosyası seçilecek ve word dosyasındaki tüm tablolar excelde tek sayfada (Sayfa 1) altalta aralarında 2 satır olacak şekilde eklenecek

 

[volki_112]

merhaba sayın hocalarım
forumda arattım makrolarla ilgili ancak yanıt bulamadım o yüzden buraya sormak istiyorum

yapılacak makro çalıştığında; word dosyası seçilecek ve word dosyasındaki tüm tablolar excelde tek sayfada (Sayfa 1) altalta aralarında 2 satır olacak şekilde eklenecek

deneyiniz.

Sub WordTablolarini_ExcelSayfa1e_AltAltaYapistir()
    Dim fd As FileDialog
    Dim fPath As String
    Dim wdApp As Object          ' Word.Application (late binding)
    Dim wdDoc As Object          ' Word.Document
    Dim wdTbl As Object          ' Word.Table
    Dim ws As Worksheet
    Dim curRow As Long
    Dim pastedLastRow As Long
    Dim createdWd As Boolean
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    ' Hedef sayfa
    Set ws = ThisWorkbook.Worksheets("Sayfa1")  ' Sayfa yoksa hata verir; istersen ActiveSheet yap
    ' Başlangıç satırı (Eğer sayfa boşsa 1; istersen değiştirebilirsin)
    curRow = 1
    
    ' Dosya seçme dialogu
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = False
        .Title = "Word dosyasını seçin (.doc veya .docx)"
        .Filters.Clear
        .Filters.Add "Word Dosyaları", "*.doc; *.docx"
        If .Show <> -1 Then
            MsgBox "Dosya seçilmedi. İşlem iptal edildi.", vbInformation
            GoTo CleanExit
        End If
        fPath = .SelectedItems(1)
    End With
    
    ' Word uygulaması aç (varsa mevcut olanı kullan)
    createdWd = False
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Err.Clear
        Set wdApp = CreateObject("Word.Application")
        createdWd = True
    End If
    On Error GoTo ErrHandler
    
    wdApp.Visible = False
    Set wdDoc = wdApp.Documents.Open(fPath, ReadOnly:=True)
    
    If wdDoc.Tables.Count = 0 Then
        MsgBox "Seçilen Word dosyasında tablo bulunamadı.", vbExclamation
        GoTo CloseAndExit
    End If
    
    ' Eğer Sayfa1'de daha önceden veri varsa son dolu satırın altından başlamak istersen:
    'If Application.WorksheetFunction.CountA(ws.Cells) > 0 Then
    '    curRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 3
    'End If
    
    Dim tIndex As Long
    For tIndex = 1 To wdDoc.Tables.Count
        Set wdTbl = wdDoc.Tables(tIndex)
        ' Tabloyu kopyala
        wdTbl.Range.Copy
        
        ' Yapıştır: A sütununun curRow satırına
        ws.Activate
        ws.Cells(curRow, "A").Select
        ws.Paste
        
        ' Yapıştırılan tablonun son satırını bul
        pastedLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        
        ' Sonraki tablonun başlangıç satırı = pastedLastRow + 3 (iki boş satır bırakmak için)
        curRow = pastedLastRow + 3
    Next tIndex
    
    MsgBox "İşlem tamamlandı. " & wdDoc.Tables.Count & " tablo Sayfa1'e yapıştırıldı.", vbInformation

CloseAndExit:
    If Not wdDoc Is Nothing Then
        wdDoc.Close SaveChanges:=False
        Set wdDoc = Nothing
    End If
    If Not wdApp Is Nothing Then
        If createdWd Then wdApp.Quit
        Set wdApp = Nothing
    End If

CleanExit:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox "Hata: " & Err.Number & " - " & Err.Description, vbCritical
    Resume CloseAndExit
End Sub

 

[modoste]

makroyu uyguladım sonuç başarılı teşekkür ederim
2. makro isteğim; her tabloyu ayrı ayrı sekmede (tablo-1,tablo-2) oluştursun
az önce bir arkadaşım bu yapılabilir mi bunu da sorabilir miyiz dediği için peşi sıra sordum sayın hocalarım

 

[volki_112]

makroyu uyguladım sonuç başarılı teşekkür ederim
2. makro isteğim; her tabloyu ayrı ayrı sekmede (tablo-1,tablo-2) oluştursun
az önce bir arkadaşım bu yapılabilir mi bunu da sorabilir miyiz dediği için peşi sıra sordum sayın hocalarım

deneyiniz.

Sub WordTablolarini_HerBiriniYeniSayfayaYapistir()
    Dim fd As FileDialog
    Dim fPath As String
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdTbl As Object
    Dim wb As Workbook
    Dim newWs As Worksheet
    Dim tblCount As Long
    Dim createdWd As Boolean
    Dim tIndex As Long
    Dim baseName As String
    Dim shtName As String
    Dim suffix As Long
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set wb = ThisWorkbook
    
    ' Dosya seçme
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = False
        .Title = "Word dosyasını seçin (.doc veya .docx)"
        .Filters.Clear
        .Filters.Add "Word Dosyaları", "*.doc; *.docx"
        If .Show <> -1 Then
            MsgBox "Dosya seçilmedi. İşlem iptal edildi.", vbInformation
            GoTo CleanExit
        End If
        fPath = .SelectedItems(1)
    End With
    
    ' Word uygulaması (late binding)
    createdWd = False
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Err.Clear
        Set wdApp = CreateObject("Word.Application")
        createdWd = True
    End If
    On Error GoTo ErrHandler
    
    wdApp.Visible = False
    Set wdDoc = wdApp.Documents.Open(fPath, ReadOnly:=True)
    
    tblCount = wdDoc.Tables.Count
    If tblCount = 0 Then
        MsgBox "Seçilen Word dosyasında tablo bulunamadı.", vbExclamation
        GoTo CloseAndExit
    End If
    
    For tIndex = 1 To tblCount
        Set wdTbl = wdDoc.Tables(tIndex)
        ' Tabloyu kopyala
        wdTbl.Range.Copy
        
        ' Yeni sayfa oluştur
        baseName = "Tablo_" & tIndex
        shtName = baseName
        suffix = 1
        ' Eğer isim zaten varsa, sonuna _(n) ekle
        Do While SheetExists(shtName, wb)
            shtName = baseName & "_(" & suffix & ")"
            suffix = suffix + 1
        Loop
        Set newWs = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        On Error Resume Next
        newWs.Name = shtName
        On Error GoTo ErrHandler
        
        ' Yapıştır: A1'e
        newWs.Range("A1").Select
        newWs.Paste
        
        ' Sütun genişliklerini otomatik sığdır
        newWs.Columns.AutoFit
        
        ' Temizle Clipboard
        Application.CutCopyMode = False
    Next tIndex
    
    MsgBox "İşlem tamamlandı. " & tblCount & " tablo, her biri yeni bir sayfaya yapıştırıldı.", vbInformation

CloseAndExit:
    If Not wdDoc Is Nothing Then
        wdDoc.Close SaveChanges:=False
        Set wdDoc = Nothing
    End If
    If Not wdApp Is Nothing Then
        If createdWd Then wdApp.Quit
        Set wdApp = Nothing
    End If

CleanExit:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub

ErrHandler:
    MsgBox "Hata: " & Err.Number & " - " & Err.Description, vbCritical
    Resume CloseAndExit
End Sub

' Yardımcı fonksiyon: belirtilen isimde bir sayfa var mı kontrol eder
Private Function SheetExists(sName As String, wb As Workbook) As Boolean
    Dim sh As Worksheet
    SheetExists = False
    For Each sh In wb.Worksheets
        If LCase(sh.Name) = LCase(sName) Then
            SheetExists = True
            Exit Function
        End If
    Next sh
End Function