Excel Sayfalarını Word Tablo aktarmak

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

Cevap: Cevap: Excel Sayfalarını Word Tablo aktarmak

İleti#21)  hadromer » 13 Eyl 2022 19:44

Yken yazdı:B sütunu toplam sütunu ve tümü tek word belgesinde.
Kod: Tümünü seç
Public myvarbaskn As Variant, myvarbask_2 As Variant
Sub Test_Hadromer()
'Excel Sayfalarındaki tabloları Word Tabloya aktarmak
' Tools / Reference ile Microsoft Word XX.X Object Library EKLENECEK
  Dim objWord As Object, objDoc As Object, N6YZD As String
  Dim N1 As String, N4 As Integer, N5 As Double
  Dim myvar As String, myvartop As Integer, sonsat As Long

Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add

objDoc.PageSetup.LeftMargin = objWord.CentimetersToPoints(1.9)
objDoc.PageSetup.RightMargin = objWord.CentimetersToPoints(1.9)

With objWord.Selection.Sections(1)

    With .Borders(wdBorderLeft)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderRight)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderTop)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderBottom)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders
        .DistanceFrom = wdBorderDistanceFromPageEdge
        .AlwaysInFront = False
        .SurroundHeader = False
        .SurroundFooter = False
        .JoinBorders = False
        .DistanceFromTop = 18
        .DistanceFromLeft = 18
        .DistanceFromBottom = 18
        .DistanceFromRight = 18
        .Shadow = False
        .EnableFirstPageInSection = True
        .EnableOtherPagesInSection = True
        .ApplyPageBordersToAllSections
    End With
End With
    With objWord.Options
        .DefaultBorderLineStyle = wdLineStyleSingle
        .DefaultBorderLineWidth = wdLineWidth050pt
        .DefaultBorderColor = wdColorAutomatic
    End With
       
For i = 1 To Sheets.Count
Worksheets(i).Select
    N1 = Worksheets(i).Name
    sonsat = Cells(Rows.Count, "b").End(xlUp).Row
    N4 = WorksheetFunction.CountA(Range("a2:a" & sonsat - 1))
    N5 = Format(Range("D" & sonsat).Value, "#.##0,0000")
    'myvar = Application.Evaluate("INDEX(A2:A" & sonsat & ",MODE(IF(A2:A" & sonsat & "<>"""",MATCH(A2:A" & sonsat & ",A2:A" & sonsat & ",0))))")
    myvar = TextMode(Range("A2:A" & sonsat))
    N6YZD = Application.SumIf(Range("A2:A" & sonsat - 1), "" & myvar & "", Range("D2:D" & sonsat - 1))
    myvartop = Application.SumIf(Range("A2:A" & sonsat - 1), "" & myvar & "", Range("D2:D" & sonsat - 1))
   
    Select Case myvar
        Case Is = "BAC": myvar = "Bacillariophyta"
        Case Is = "CHA": myvar = "Charophyta"
        Case Is = "CHL": myvar = "Chlorophyta"
        Case Is = "CRY": myvar = "Cryptophyta"
        Case Is = "CYA": myvar = "Cyanobacteria"
        Case Is = "EUG": myvar = "Euglenozoa"
        Case Is = "MIO": myvar = "Miozoa"
        Case Is = "OCH": myvar = "Ochrophyta"
    End Select

Call Test_H

With objWord.Selection
    .ParagraphFormat.Alignment = wdAlignParagraphJustify
    .Font.Name = "Times New Roman"
    .Font.Size = 12
    .TypeText Text:="3.1 Aras Havzası" & vbLf & "3.1.2 " & N1
    .HomeKey , Extend:=wdExtend
    .Range.HighlightColorIndex = 7
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Range.HighlightColorIndex = wdNoHighlight
    .TypeText Text:="Biyolojik İzleme Bulguları" & vbLf & "Fitoplankton"
    .MoveUp Unit:=wdParagraph, Count:=4, Extend:=wdExtend
    .Font.Bold = True
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Font.Bold = False
    .TypeText Text:=N1 & " Gölü'nde birinci dönemde yapılan örneklemede A noktasında toplam " _
    & N4 & " takson teşhis edilmiştir ve toplam fitoplanktonun biyohacmi " & N5 & " mm3"
    .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    .Font.Superscript = True
    .Collapse wdCollapseEnd:     .Font.Superscript = False
    .TypeText Text:="/l olarak belirlenmiştir. Fitoplankton kompozisyonunda " & myvar & " toplam fitoplanktonun % " _
    & Format(N6YZD / N5, "#,##0.00") & "'ünü oluşturmaktadır. " & myvar & "'dan " & myvarbask_2 & " baskın olmuştur."
    .Find.Execute FindText:=myvarbask_2, Forward:=False: .Font.Italic = True
    .EndKey
    .TypeParagraph
    .TypeText Text:="Tablo 3.1.2.18.1.4. " & N1 & " noktası birinci dönem fitoplankton türleri, fitoplankton bolluğu, biyohacim ve kompozisyonu"
    .MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend
    .Font.Bold = True
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Font.Name = "Times New Roman"
    .Font.Size = 10

    Sheets(i).Range("A1").CurrentRegion.Copy
    .PasteExcelTable False, False, False
    Application.CutCopyMode = False

With .Tables(1)
    .Range.Font.Name = "Times New Roman"
    .Range.Font.Size = 10
    .Borders.Enable = True
    .Rows.Alignment = wdAlignRowCenter
    .Range.ParagraphFormat.SpaceAfterAuto = False
    .Range.ParagraphFormat.SpaceAfter = 6
    .Range.ParagraphFormat.SpaceBeforeAuto = False
    .Range.ParagraphFormat.SpaceBefore = 6
    .Columns(1).Width = objWord.CentimetersToPoints(1.75)
    .Columns(2).Width = objWord.CentimetersToPoints(5)
    .Columns(3).Width = objWord.CentimetersToPoints(2.5)
    .Columns(4).Width = objWord.CentimetersToPoints(2.5)
    .Columns(5).Width = objWord.CentimetersToPoints(2.5)
    .Columns(6).Width = objWord.CentimetersToPoints(2.5)
    '.Columns(7).Width = objWord.CentimetersToPoints(1.75)

Set Rng = .cell(1, 1).Range
Rng.End = .cell(1, 6).Range.End
Rng.Cells.Shading.BackgroundPatternColor = 16777164
Set Rng = .cell(sonsat, 1).Range
Rng.End = .cell(sonsat, 2).Range.End
Rng.Cells.Merge

Deg = "*BAC: Bacillariophyta, CHA: Charophyta, CHL: Chlorophyta, CRY: Cryptophyta, CYA: Cyanobacteria," & _
"EUG: Euglenophyta, MIO: Miozoa, OCH: Ochrophyta **H: Hassas, T: Toleranslı, H/T: Farksız türler"

End With
    .TypeText Text:=Deg
    .InsertBreak Type:=wdPageBreak
End With

myvarbaskn = vbNullString: myvarbask_2 = vbNullString

Next

objWord.Selection.MoveLeft Unit:=wdCharacter, Count:=2
objWord.Selection.Delete: objWord.Selection.Delete
objDoc.SaveAs ThisWorkbook.Path & "\" & Sheets(1).Name & ".docx"
objDoc.Close
objWord.Quit

Set objDoc = Nothing
Set objWord = Nothing
Set Rng = Nothing

MsgBox "İşlem Tamam"
End Sub

Sub Test_H()
Dim mycell As Range, sonsat As Long
Dim myvar As String, ilk As Integer, son As Integer

Application.DisplayAlerts = False

sonsat = Cells(Rows.Count, "b").End(xlUp).Row
Range("a1:G1").Font.Bold = True
Range("a" & sonsat & ":G" & sonsat).Font.Bold = True

myvar = Application.Evaluate("INDEX(A2:A" & sonsat & ",MODE(IF(A2:A" & sonsat & "<>"""",MATCH(A2:A" & sonsat & ",A2:A" & sonsat & ",0))))")

For x = 2 To sonsat
Set mycell = Cells(x, 1)
If mycell.Value = mycell.Offset(1, 0).Value Then
    ilk = mycell.Row
    Do Until mycell <> mycell.Offset(1, 0).Value
    Range(mycell, mycell.Offset(1, 0)).Merge
    x = x + 1
    Loop
son = x
If mycell.Value = myvar Then
myvarbaskn = Application.Max(Range("d" & ilk & ":d" & son))
'myvarbask_2 = Application.Max(Range("d" & ilk & ":d" & son)).Offset(0, -2)
myvarbask_2 = Application.Index(Range("b" & ilk & ":b" & son), Application.Match(Application.Max(Range("d" & ilk & ":d" & son)), Range("d" & ilk & ":d" & son), 0))
End If
Range("E" & ilk & ":E" & son).Merge
Range("F" & ilk & ":F" & son).Merge
End If
    If x >= sonsat - 1 Then Exit For
Next

Range("B2:B" & sonsat - 1).Font.Italic = True
Range("A2:B" & sonsat).HorizontalAlignment = xlLeft
Range("C2:F" & sonsat).HorizontalAlignment = xlRight
'Range("G2:G" & sonsat).HorizontalAlignment = xlCenter
Application.DisplayAlerts = True

Set mycell = Nothing

End Sub

Function TextMode(oRange As Range)
oMax = 0
For Each cell In oRange
oCount = Application.WorksheetFunction.CountIf(oRange, cell.Value)
If oCount > oMax Then oMax = oCount: TextMode = cell.Value
Next cell
End Function



Hocam elinize emeğinize sağlık. Harikasınız. Sagolun
Kullanıcı avatarı
hadromer
Yeni Başlamış
 
Kayıt: 05 Kas 2017 21:44
Meslek: Ogrenci
Yaş: 29
İleti: 72
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: ankara

Yıllık Maaş Bordrosu Hesaplama 2022

Cevap: Cevap: Excel Sayfalarını Word Tablo aktarmak

İleti#22)  hadromer » 15 Eyl 2022 18:11

Yken yazdı:B sütunu toplam sütunu ve tümü tek word belgesinde.
Kod: Tümünü seç
Public myvarbaskn As Variant, myvarbask_2 As Variant
Sub Test_Hadromer()
'Excel Sayfalarındaki tabloları Word Tabloya aktarmak
' Tools / Reference ile Microsoft Word XX.X Object Library EKLENECEK
  Dim objWord As Object, objDoc As Object, N6YZD As String
  Dim N1 As String, N4 As Integer, N5 As Double
  Dim myvar As String, myvartop As Integer, sonsat As Long

Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add

objDoc.PageSetup.LeftMargin = objWord.CentimetersToPoints(1.9)
objDoc.PageSetup.RightMargin = objWord.CentimetersToPoints(1.9)

With objWord.Selection.Sections(1)

    With .Borders(wdBorderLeft)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderRight)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderTop)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderBottom)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders
        .DistanceFrom = wdBorderDistanceFromPageEdge
        .AlwaysInFront = False
        .SurroundHeader = False
        .SurroundFooter = False
        .JoinBorders = False
        .DistanceFromTop = 18
        .DistanceFromLeft = 18
        .DistanceFromBottom = 18
        .DistanceFromRight = 18
        .Shadow = False
        .EnableFirstPageInSection = True
        .EnableOtherPagesInSection = True
        .ApplyPageBordersToAllSections
    End With
End With
    With objWord.Options
        .DefaultBorderLineStyle = wdLineStyleSingle
        .DefaultBorderLineWidth = wdLineWidth050pt
        .DefaultBorderColor = wdColorAutomatic
    End With
       
For i = 1 To Sheets.Count
Worksheets(i).Select
    N1 = Worksheets(i).Name
    sonsat = Cells(Rows.Count, "b").End(xlUp).Row
    N4 = WorksheetFunction.CountA(Range("a2:a" & sonsat - 1))
    N5 = Format(Range("D" & sonsat).Value, "#.##0,0000")
    'myvar = Application.Evaluate("INDEX(A2:A" & sonsat & ",MODE(IF(A2:A" & sonsat & "<>"""",MATCH(A2:A" & sonsat & ",A2:A" & sonsat & ",0))))")
    myvar = TextMode(Range("A2:A" & sonsat))
    N6YZD = Application.SumIf(Range("A2:A" & sonsat - 1), "" & myvar & "", Range("D2:D" & sonsat - 1))
    myvartop = Application.SumIf(Range("A2:A" & sonsat - 1), "" & myvar & "", Range("D2:D" & sonsat - 1))
   
    Select Case myvar
        Case Is = "BAC": myvar = "Bacillariophyta"
        Case Is = "CHA": myvar = "Charophyta"
        Case Is = "CHL": myvar = "Chlorophyta"
        Case Is = "CRY": myvar = "Cryptophyta"
        Case Is = "CYA": myvar = "Cyanobacteria"
        Case Is = "EUG": myvar = "Euglenozoa"
        Case Is = "MIO": myvar = "Miozoa"
        Case Is = "OCH": myvar = "Ochrophyta"
    End Select

Call Test_H

With objWord.Selection
    .ParagraphFormat.Alignment = wdAlignParagraphJustify
    .Font.Name = "Times New Roman"
    .Font.Size = 12
    .TypeText Text:="3.1 Aras Havzası" & vbLf & "3.1.2 " & N1
    .HomeKey , Extend:=wdExtend
    .Range.HighlightColorIndex = 7
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Range.HighlightColorIndex = wdNoHighlight
    .TypeText Text:="Biyolojik İzleme Bulguları" & vbLf & "Fitoplankton"
    .MoveUp Unit:=wdParagraph, Count:=4, Extend:=wdExtend
    .Font.Bold = True
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Font.Bold = False
    .TypeText Text:=N1 & " Gölü'nde birinci dönemde yapılan örneklemede A noktasında toplam " _
    & N4 & " takson teşhis edilmiştir ve toplam fitoplanktonun biyohacmi " & N5 & " mm3"
    .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    .Font.Superscript = True
    .Collapse wdCollapseEnd:     .Font.Superscript = False
    .TypeText Text:="/l olarak belirlenmiştir. Fitoplankton kompozisyonunda " & myvar & " toplam fitoplanktonun % " _
    & Format(N6YZD / N5, "#,##0.00") & "'ünü oluşturmaktadır. " & myvar & "'dan " & myvarbask_2 & " baskın olmuştur."
    .Find.Execute FindText:=myvarbask_2, Forward:=False: .Font.Italic = True
    .EndKey
    .TypeParagraph
    .TypeText Text:="Tablo 3.1.2.18.1.4. " & N1 & " noktası birinci dönem fitoplankton türleri, fitoplankton bolluğu, biyohacim ve kompozisyonu"
    .MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend
    .Font.Bold = True
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Font.Name = "Times New Roman"
    .Font.Size = 10

    Sheets(i).Range("A1").CurrentRegion.Copy
    .PasteExcelTable False, False, False
    Application.CutCopyMode = False

With .Tables(1)
    .Range.Font.Name = "Times New Roman"
    .Range.Font.Size = 10
    .Borders.Enable = True
    .Rows.Alignment = wdAlignRowCenter
    .Range.ParagraphFormat.SpaceAfterAuto = False
    .Range.ParagraphFormat.SpaceAfter = 6
    .Range.ParagraphFormat.SpaceBeforeAuto = False
    .Range.ParagraphFormat.SpaceBefore = 6
    .Columns(1).Width = objWord.CentimetersToPoints(1.75)
    .Columns(2).Width = objWord.CentimetersToPoints(5)
    .Columns(3).Width = objWord.CentimetersToPoints(2.5)
    .Columns(4).Width = objWord.CentimetersToPoints(2.5)
    .Columns(5).Width = objWord.CentimetersToPoints(2.5)
    .Columns(6).Width = objWord.CentimetersToPoints(2.5)
    '.Columns(7).Width = objWord.CentimetersToPoints(1.75)

Set Rng = .cell(1, 1).Range
Rng.End = .cell(1, 6).Range.End
Rng.Cells.Shading.BackgroundPatternColor = 16777164
Set Rng = .cell(sonsat, 1).Range
Rng.End = .cell(sonsat, 2).Range.End
Rng.Cells.Merge

Deg = "*BAC: Bacillariophyta, CHA: Charophyta, CHL: Chlorophyta, CRY: Cryptophyta, CYA: Cyanobacteria," & _
"EUG: Euglenophyta, MIO: Miozoa, OCH: Ochrophyta **H: Hassas, T: Toleranslı, H/T: Farksız türler"

End With
    .TypeText Text:=Deg
    .InsertBreak Type:=wdPageBreak
End With

myvarbaskn = vbNullString: myvarbask_2 = vbNullString

Next

objWord.Selection.MoveLeft Unit:=wdCharacter, Count:=2
objWord.Selection.Delete: objWord.Selection.Delete
objDoc.SaveAs ThisWorkbook.Path & "\" & Sheets(1).Name & ".docx"
objDoc.Close
objWord.Quit

Set objDoc = Nothing
Set objWord = Nothing
Set Rng = Nothing

MsgBox "İşlem Tamam"
End Sub

Sub Test_H()
Dim mycell As Range, sonsat As Long
Dim myvar As String, ilk As Integer, son As Integer

Application.DisplayAlerts = False

sonsat = Cells(Rows.Count, "b").End(xlUp).Row
Range("a1:G1").Font.Bold = True
Range("a" & sonsat & ":G" & sonsat).Font.Bold = True

myvar = Application.Evaluate("INDEX(A2:A" & sonsat & ",MODE(IF(A2:A" & sonsat & "<>"""",MATCH(A2:A" & sonsat & ",A2:A" & sonsat & ",0))))")

For x = 2 To sonsat
Set mycell = Cells(x, 1)
If mycell.Value = mycell.Offset(1, 0).Value Then
    ilk = mycell.Row
    Do Until mycell <> mycell.Offset(1, 0).Value
    Range(mycell, mycell.Offset(1, 0)).Merge
    x = x + 1
    Loop
son = x
If mycell.Value = myvar Then
myvarbaskn = Application.Max(Range("d" & ilk & ":d" & son))
'myvarbask_2 = Application.Max(Range("d" & ilk & ":d" & son)).Offset(0, -2)
myvarbask_2 = Application.Index(Range("b" & ilk & ":b" & son), Application.Match(Application.Max(Range("d" & ilk & ":d" & son)), Range("d" & ilk & ":d" & son), 0))
End If
Range("E" & ilk & ":E" & son).Merge
Range("F" & ilk & ":F" & son).Merge
End If
    If x >= sonsat - 1 Then Exit For
Next

Range("B2:B" & sonsat - 1).Font.Italic = True
Range("A2:B" & sonsat).HorizontalAlignment = xlLeft
Range("C2:F" & sonsat).HorizontalAlignment = xlRight
'Range("G2:G" & sonsat).HorizontalAlignment = xlCenter
Application.DisplayAlerts = True

Set mycell = Nothing

End Sub

Function TextMode(oRange As Range)
oMax = 0
For Each cell In oRange
oCount = Application.WorksheetFunction.CountIf(oRange, cell.Value)
If oCount > oMax Then oMax = oCount: TextMode = cell.Value
Next cell
End Function




Hocam Merhaba,
size yeniden yazmak zorunda kaldım. Umarım vaktiniz olur.
Kod harika çalışıyor. Ancak bir kaç değişiklik yapmam gerekti.
Bunu da sizden başkası yapamayacağı için size yazdım.

Hocam
1-)Tablo numaraları "Tablo 3.1.2.18.1.4. " şeklindeydi. Bunun yerine 1'den başlayıp ardışık olacak şekilde yazdırması gerekiyor. "Tablo 1.", "Tablo 2." gibi
2-) Ben excel dosyasına "İndikatör (H/T)**" başlıklı bir sütun daha ekledim. Kod word tablosuna bunu aktarıyor ancak bu sütun başlığını renklendirmiyor. Renklendirmeye bunu da dahil edebilir miyiz ?
3-) Eklenen yeni sütunla birlikte tablo word şablonundaki kenarlıklardan biraz taşıyor. Ve word tablo içindeki veriler tablo içerisinde ortalı değil en altta duruyor. Tablo sayısı az olsa tek tek Tablo özellikleri/hücre/ortala yaparım ama 300'den fazla tablo var.

Yardımlarınız için şimdiden teşekkür ederim.
Kullanıcı avatarı
hadromer
Yeni Başlamış
 
Kayıt: 05 Kas 2017 21:44
Meslek: Ogrenci
Yaş: 29
İleti: 72
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: ankara

Cevap: Excel Sayfalarını Word Tablo aktarmak

İleti#23)  Yken » 15 Eyl 2022 23:52

Kod: Tümünü seç
Public myvarbaskn As Variant, myvarbask_2 As Variant
Sub Test_Hadromer()
'BU DA TOPLAM İFADESİ B SÜTUNUNDA İSE VE TÜM TABLOLAR TEK WORDDE OLACAK ŞEKİLDE.
'Excel Sayfalarındaki tabloları Word Tabloya aktarmak
' Tools / Reference ile Microsoft Word XX.X Object Library EKLENECEK
  Dim objWord As Object, objDoc As Object, N6YZD As String
  Dim N1 As String, N4 As Integer, N5 As Double
  Dim myvar As String, myvartop As Integer, sonsat As Long

Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add

objDoc.PageSetup.LeftMargin = objWord.CentimetersToPoints(1.9)
objDoc.PageSetup.RightMargin = objWord.CentimetersToPoints(1.9)

With objWord.Selection.Sections(1)

    With .Borders(wdBorderLeft)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderRight)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderTop)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderBottom)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders
        .DistanceFrom = wdBorderDistanceFromPageEdge
        .AlwaysInFront = False
        .SurroundHeader = False
        .SurroundFooter = False
        .JoinBorders = False
        .DistanceFromTop = 18
        .DistanceFromLeft = 18
        .DistanceFromBottom = 18
        .DistanceFromRight = 18
        .Shadow = False
        .EnableFirstPageInSection = True
        .EnableOtherPagesInSection = True
        .ApplyPageBordersToAllSections
    End With
End With
    With objWord.Options
        .DefaultBorderLineStyle = wdLineStyleSingle
        .DefaultBorderLineWidth = wdLineWidth050pt
        .DefaultBorderColor = wdColorAutomatic
    End With
       
For i = 1 To Sheets.Count
Worksheets(i).Select
    N1 = Worksheets(i).Name
    sonsat = Cells(Rows.Count, "b").End(xlUp).Row
    N4 = WorksheetFunction.CountA(Range("a2:a" & sonsat - 1))
    N5 = Format(Range("D" & sonsat).Value, "#.##0,0000")
    'myvar = Application.Evaluate("INDEX(A2:A" & sonsat & ",MODE(IF(A2:A" & sonsat & "<>"""",MATCH(A2:A" & sonsat & ",A2:A" & sonsat & ",0))))")
    myvar = TextMode(Range("A2:A" & sonsat))
    N6YZD = Application.SumIf(Range("A2:A" & sonsat - 1), "" & myvar & "", Range("D2:D" & sonsat - 1))
    myvartop = Application.SumIf(Range("A2:A" & sonsat - 1), "" & myvar & "", Range("D2:D" & sonsat - 1))
   
    Select Case myvar
        Case Is = "BAC": myvar = "Bacillariophyta"
        Case Is = "CHA": myvar = "Charophyta"
        Case Is = "CHL": myvar = "Chlorophyta"
        Case Is = "CRY": myvar = "Cryptophyta"
        Case Is = "CYA": myvar = "Cyanobacteria"
        Case Is = "EUG": myvar = "Euglenozoa"
        Case Is = "MIO": myvar = "Miozoa"
        Case Is = "OCH": myvar = "Ochrophyta"
    End Select

Call Test_H

With objWord.Selection
    .ParagraphFormat.Alignment = wdAlignParagraphJustify
    .Font.Name = "Times New Roman"
    .Font.Size = 12
    .TypeText Text:="3.1 Aras Havzası" & vbLf & "3.1.2 " & N1
    .HomeKey , Extend:=wdExtend
    .Range.HighlightColorIndex = 7
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Range.HighlightColorIndex = wdNoHighlight
    .TypeText Text:="Biyolojik İzleme Bulguları" & vbLf & "Fitoplankton"
    .MoveUp Unit:=wdParagraph, Count:=4, Extend:=wdExtend
    .Font.Bold = True
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Font.Bold = False
    .TypeText Text:=N1 & " Gölü'nde birinci dönemde yapılan örneklemede A noktasında toplam " _
    & N4 & " takson teşhis edilmiştir ve toplam fitoplanktonun biyohacmi " & N5 & " mm3"
    .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    .Font.Superscript = True
    .Collapse wdCollapseEnd:     .Font.Superscript = False
    .TypeText Text:="/l olarak belirlenmiştir. Fitoplankton kompozisyonunda " & myvar & " toplam fitoplanktonun % " _
    & Format(N6YZD / N5, "#,##0.00") & "'ünü oluşturmaktadır. " & myvar & "'dan " & myvarbask_2 & " baskın olmuştur."
    .Find.Execute FindText:=myvarbask_2, Forward:=False: .Font.Italic = True
    .EndKey
    .TypeParagraph
    .TypeText Text:="Tablo " & i & ". " & N1 & " noktası birinci dönem fitoplankton türleri, fitoplankton bolluğu, biyohacim ve kompozisyonu"
    .MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend
    .Font.Bold = True
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Font.Name = "Times New Roman"
    .Font.Size = 10

    Sheets(i).Range("A1").CurrentRegion.Copy
    .PasteExcelTable False, False, False
    Application.CutCopyMode = False
MsgBox ""

With .Tables(1)
    .Range.Cells(1).Range.Rows.HeadingFormat = True
    .Range.Font.Name = "Times New Roman"
    .Range.Font.Size = 10
    .Borders.Enable = True
    .Rows.Alignment = wdAlignRowCenter
    .Range.ParagraphFormat.SpaceAfterAuto = False
    .Range.ParagraphFormat.SpaceAfter = 6
    .Range.ParagraphFormat.SpaceBeforeAuto = False
    .Range.ParagraphFormat.SpaceBefore = 6
    .Columns(1).Width = objWord.CentimetersToPoints(1.75)
    .Columns(2).Width = objWord.CentimetersToPoints(5)
    .Columns(3).Width = objWord.CentimetersToPoints(2.5)
    .Columns(4).Width = objWord.CentimetersToPoints(2.5)
    .Columns(5).Width = objWord.CentimetersToPoints(2.5)
    .Columns(6).Width = objWord.CentimetersToPoints(2.5)
    .Columns(7).Width = objWord.CentimetersToPoints(1.75)

Set rng = .cell(1, 1).Range
rng.End = .cell(1, 7).Range.End
rng.Cells.Shading.BackgroundPatternColor = 16777164
Set rng = .cell(sonsat, 1).Range
rng.End = .cell(sonsat, 2).Range.End
rng.Cells.Merge

Deg = "*BAC: Bacillariophyta, CHA: Charophyta, CHL: Chlorophyta, CRY: Cryptophyta, CYA: Cyanobacteria," & _
"EUG: Euglenophyta, MIO: Miozoa, OCH: Ochrophyta **H: Hassas, T: Toleranslı, H/T: Farksız türler"

End With
    .TypeText Text:=Deg
    .InsertBreak Type:=wdPageBreak
End With

myvarbaskn = vbNullString: myvarbask_2 = vbNullString

Next

objWord.Selection.MoveLeft Unit:=wdCharacter, Count:=2
objWord.Selection.Delete: objWord.Selection.Delete
objDoc.SaveAs ThisWorkbook.Path & "\" & Sheets(1).Name & ".docx"
objDoc.Close
objWord.Quit

Set objDoc = Nothing
Set objWord = Nothing
Set rng = Nothing

MsgBox "İşlem Tamam"
End Sub

Sub Test_H()
Dim mycell As Range, sonsat As Long
Dim myvar As String, ilk As Integer, son As Integer

Application.DisplayAlerts = False

sonsat = Cells(Rows.Count, "b").End(xlUp).Row
Range("a1:G1").Font.Bold = True
Range("a" & sonsat & ":G" & sonsat).Font.Bold = True

myvar = Application.Evaluate("INDEX(A2:A" & sonsat & ",MODE(IF(A2:A" & sonsat & "<>"""",MATCH(A2:A" & sonsat & ",A2:A" & sonsat & ",0))))")

For x = 2 To sonsat
Set mycell = Cells(x, 1)
If mycell.Value = mycell.Offset(1, 0).Value Then
    ilk = mycell.Row
    Do Until mycell <> mycell.Offset(1, 0).Value
    Range(mycell, mycell.Offset(1, 0)).Merge
    x = x + 1
    Loop
son = x
If mycell.Value = myvar Then
myvarbaskn = Application.Max(Range("d" & ilk & ":d" & son))
'myvarbask_2 = Application.Max(Range("d" & ilk & ":d" & son)).Offset(0, -2)
myvarbask_2 = Application.Index(Range("b" & ilk & ":b" & son), Application.Match(Application.Max(Range("d" & ilk & ":d" & son)), Range("d" & ilk & ":d" & son), 0))
End If
Range("E" & ilk & ":E" & son).Merge
Range("F" & ilk & ":F" & son).Merge
End If
    If x >= sonsat - 1 Then Exit For
Next

Range("B2:B" & sonsat - 1).Font.Italic = True
Range("A2:B" & sonsat).HorizontalAlignment = xlLeft
Range("C2:F" & sonsat).HorizontalAlignment = xlRight
Range("G2:G" & sonsat).HorizontalAlignment = xlCenter
Range("A1").CurrentRegion.VerticalAlignment = xlCenter
Application.DisplayAlerts = True

Set mycell = Nothing

End Sub

Function TextMode(oRange As Range)
oMax = 0
For Each cell In oRange
oCount = Application.WorksheetFunction.CountIf(oRange, cell.Value)
If oCount > oMax Then oMax = oCount: TextMode = cell.Value
Next cell
End Function

Kullanıcı avatarı
Yken
Yeni Başlamış
 
Kayıt: 07 Kas 2014 11:06
Meslek: Muhasebe
Yaş: 56
İleti: 51
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Cevap: Excel Sayfalarını Word Tablo aktarmak

İleti#24)  muzos80 » 16 Eyl 2022 12:46

Merhaba Nasıl çalışıyor çözemedim deneme yaptığımda " Run-time error '5941': hatası veriyor benim dosyamda çalışması için nerelerde değişiklik yapmam gerekiyor
Kullanıcı avatarı
muzos80
Siteye Alışmış
 
Kayıt: 10 Arl 2016 23:14
Meslek: TPM
Yaş: 49
İleti: 207
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul/kartal

REKLAM
Excel Logo XML Oluşturucu
Logo Object Designer ile Uyarlama

Cevap: Excel Sayfalarını Word Tablo aktarmak

İleti#25)  muzos80 » 16 Eyl 2022 12:48

makronun " With .Borders(wdBorderLeft " kısmında hata veriyor
Kullanıcı avatarı
muzos80
Siteye Alışmış
 
Kayıt: 10 Arl 2016 23:14
Meslek: TPM
Yaş: 49
İleti: 207
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul/kartal

Cevap: Cevap: Excel Sayfalarını Word Tablo aktarmak

İleti#26)  hadromer » 16 Eyl 2022 13:00

muzos80 yazdı:makronun " With .Borders(wdBorderLeft " kısmında hata veriyor

Dosyanızı paylaşabilir misiniz kontrol edeyim
Kullanıcı avatarı
hadromer
Yeni Başlamış
 
Kayıt: 05 Kas 2017 21:44
Meslek: Ogrenci
Yaş: 29
İleti: 72
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: ankara

REKLAM
ETA - Excel Konsolide Raporlama
ETA Excel Personel Entegre Raporu

Cevap: Cevap: Excel Sayfalarını Word Tablo aktarmak

İleti#27)  hadromer » 16 Eyl 2022 13:01

Yken yazdı:
Kod: Tümünü seç
Public myvarbaskn As Variant, myvarbask_2 As Variant
Sub Test_Hadromer()
'BU DA TOPLAM İFADESİ B SÜTUNUNDA İSE VE TÜM TABLOLAR TEK WORDDE OLACAK ŞEKİLDE.
'Excel Sayfalarındaki tabloları Word Tabloya aktarmak
' Tools / Reference ile Microsoft Word XX.X Object Library EKLENECEK
  Dim objWord As Object, objDoc As Object, N6YZD As String
  Dim N1 As String, N4 As Integer, N5 As Double
  Dim myvar As String, myvartop As Integer, sonsat As Long

Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add

objDoc.PageSetup.LeftMargin = objWord.CentimetersToPoints(1.9)
objDoc.PageSetup.RightMargin = objWord.CentimetersToPoints(1.9)

With objWord.Selection.Sections(1)

    With .Borders(wdBorderLeft)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderRight)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderTop)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders(wdBorderBottom)
        .LineStyle = wdLineStyleThinThickSmallGap
        .LineWidth = wdLineWidth300pt
        .Color = 8210719
    End With
    With .Borders
        .DistanceFrom = wdBorderDistanceFromPageEdge
        .AlwaysInFront = False
        .SurroundHeader = False
        .SurroundFooter = False
        .JoinBorders = False
        .DistanceFromTop = 18
        .DistanceFromLeft = 18
        .DistanceFromBottom = 18
        .DistanceFromRight = 18
        .Shadow = False
        .EnableFirstPageInSection = True
        .EnableOtherPagesInSection = True
        .ApplyPageBordersToAllSections
    End With
End With
    With objWord.Options
        .DefaultBorderLineStyle = wdLineStyleSingle
        .DefaultBorderLineWidth = wdLineWidth050pt
        .DefaultBorderColor = wdColorAutomatic
    End With
       
For i = 1 To Sheets.Count
Worksheets(i).Select
    N1 = Worksheets(i).Name
    sonsat = Cells(Rows.Count, "b").End(xlUp).Row
    N4 = WorksheetFunction.CountA(Range("a2:a" & sonsat - 1))
    N5 = Format(Range("D" & sonsat).Value, "#.##0,0000")
    'myvar = Application.Evaluate("INDEX(A2:A" & sonsat & ",MODE(IF(A2:A" & sonsat & "<>"""",MATCH(A2:A" & sonsat & ",A2:A" & sonsat & ",0))))")
    myvar = TextMode(Range("A2:A" & sonsat))
    N6YZD = Application.SumIf(Range("A2:A" & sonsat - 1), "" & myvar & "", Range("D2:D" & sonsat - 1))
    myvartop = Application.SumIf(Range("A2:A" & sonsat - 1), "" & myvar & "", Range("D2:D" & sonsat - 1))
   
    Select Case myvar
        Case Is = "BAC": myvar = "Bacillariophyta"
        Case Is = "CHA": myvar = "Charophyta"
        Case Is = "CHL": myvar = "Chlorophyta"
        Case Is = "CRY": myvar = "Cryptophyta"
        Case Is = "CYA": myvar = "Cyanobacteria"
        Case Is = "EUG": myvar = "Euglenozoa"
        Case Is = "MIO": myvar = "Miozoa"
        Case Is = "OCH": myvar = "Ochrophyta"
    End Select

Call Test_H

With objWord.Selection
    .ParagraphFormat.Alignment = wdAlignParagraphJustify
    .Font.Name = "Times New Roman"
    .Font.Size = 12
    .TypeText Text:="3.1 Aras Havzası" & vbLf & "3.1.2 " & N1
    .HomeKey , Extend:=wdExtend
    .Range.HighlightColorIndex = 7
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Range.HighlightColorIndex = wdNoHighlight
    .TypeText Text:="Biyolojik İzleme Bulguları" & vbLf & "Fitoplankton"
    .MoveUp Unit:=wdParagraph, Count:=4, Extend:=wdExtend
    .Font.Bold = True
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Font.Bold = False
    .TypeText Text:=N1 & " Gölü'nde birinci dönemde yapılan örneklemede A noktasında toplam " _
    & N4 & " takson teşhis edilmiştir ve toplam fitoplanktonun biyohacmi " & N5 & " mm3"
    .MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    .Font.Superscript = True
    .Collapse wdCollapseEnd:     .Font.Superscript = False
    .TypeText Text:="/l olarak belirlenmiştir. Fitoplankton kompozisyonunda " & myvar & " toplam fitoplanktonun % " _
    & Format(N6YZD / N5, "#,##0.00") & "'ünü oluşturmaktadır. " & myvar & "'dan " & myvarbask_2 & " baskın olmuştur."
    .Find.Execute FindText:=myvarbask_2, Forward:=False: .Font.Italic = True
    .EndKey
    .TypeParagraph
    .TypeText Text:="Tablo " & i & ". " & N1 & " noktası birinci dönem fitoplankton türleri, fitoplankton bolluğu, biyohacim ve kompozisyonu"
    .MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend
    .Font.Bold = True
    .Collapse wdCollapseEnd
    .TypeParagraph
    .Font.Name = "Times New Roman"
    .Font.Size = 10

    Sheets(i).Range("A1").CurrentRegion.Copy
    .PasteExcelTable False, False, False
    Application.CutCopyMode = False
MsgBox ""

With .Tables(1)
    .Range.Cells(1).Range.Rows.HeadingFormat = True
    .Range.Font.Name = "Times New Roman"
    .Range.Font.Size = 10
    .Borders.Enable = True
    .Rows.Alignment = wdAlignRowCenter
    .Range.ParagraphFormat.SpaceAfterAuto = False
    .Range.ParagraphFormat.SpaceAfter = 6
    .Range.ParagraphFormat.SpaceBeforeAuto = False
    .Range.ParagraphFormat.SpaceBefore = 6
    .Columns(1).Width = objWord.CentimetersToPoints(1.75)
    .Columns(2).Width = objWord.CentimetersToPoints(5)
    .Columns(3).Width = objWord.CentimetersToPoints(2.5)
    .Columns(4).Width = objWord.CentimetersToPoints(2.5)
    .Columns(5).Width = objWord.CentimetersToPoints(2.5)
    .Columns(6).Width = objWord.CentimetersToPoints(2.5)
    .Columns(7).Width = objWord.CentimetersToPoints(1.75)

Set rng = .cell(1, 1).Range
rng.End = .cell(1, 7).Range.End
rng.Cells.Shading.BackgroundPatternColor = 16777164
Set rng = .cell(sonsat, 1).Range
rng.End = .cell(sonsat, 2).Range.End
rng.Cells.Merge

Deg = "*BAC: Bacillariophyta, CHA: Charophyta, CHL: Chlorophyta, CRY: Cryptophyta, CYA: Cyanobacteria," & _
"EUG: Euglenophyta, MIO: Miozoa, OCH: Ochrophyta **H: Hassas, T: Toleranslı, H/T: Farksız türler"

End With
    .TypeText Text:=Deg
    .InsertBreak Type:=wdPageBreak
End With

myvarbaskn = vbNullString: myvarbask_2 = vbNullString

Next

objWord.Selection.MoveLeft Unit:=wdCharacter, Count:=2
objWord.Selection.Delete: objWord.Selection.Delete
objDoc.SaveAs ThisWorkbook.Path & "\" & Sheets(1).Name & ".docx"
objDoc.Close
objWord.Quit

Set objDoc = Nothing
Set objWord = Nothing
Set rng = Nothing

MsgBox "İşlem Tamam"
End Sub

Sub Test_H()
Dim mycell As Range, sonsat As Long
Dim myvar As String, ilk As Integer, son As Integer

Application.DisplayAlerts = False

sonsat = Cells(Rows.Count, "b").End(xlUp).Row
Range("a1:G1").Font.Bold = True
Range("a" & sonsat & ":G" & sonsat).Font.Bold = True

myvar = Application.Evaluate("INDEX(A2:A" & sonsat & ",MODE(IF(A2:A" & sonsat & "<>"""",MATCH(A2:A" & sonsat & ",A2:A" & sonsat & ",0))))")

For x = 2 To sonsat
Set mycell = Cells(x, 1)
If mycell.Value = mycell.Offset(1, 0).Value Then
    ilk = mycell.Row
    Do Until mycell <> mycell.Offset(1, 0).Value
    Range(mycell, mycell.Offset(1, 0)).Merge
    x = x + 1
    Loop
son = x
If mycell.Value = myvar Then
myvarbaskn = Application.Max(Range("d" & ilk & ":d" & son))
'myvarbask_2 = Application.Max(Range("d" & ilk & ":d" & son)).Offset(0, -2)
myvarbask_2 = Application.Index(Range("b" & ilk & ":b" & son), Application.Match(Application.Max(Range("d" & ilk & ":d" & son)), Range("d" & ilk & ":d" & son), 0))
End If
Range("E" & ilk & ":E" & son).Merge
Range("F" & ilk & ":F" & son).Merge
End If
    If x >= sonsat - 1 Then Exit For
Next

Range("B2:B" & sonsat - 1).Font.Italic = True
Range("A2:B" & sonsat).HorizontalAlignment = xlLeft
Range("C2:F" & sonsat).HorizontalAlignment = xlRight
Range("G2:G" & sonsat).HorizontalAlignment = xlCenter
Range("A1").CurrentRegion.VerticalAlignment = xlCenter
Application.DisplayAlerts = True

Set mycell = Nothing

End Sub

Function TextMode(oRange As Range)
oMax = 0
For Each cell In oRange
oCount = Application.WorksheetFunction.CountIf(oRange, cell.Value)
If oCount > oMax Then oMax = oCount: TextMode = cell.Value
Next cell
End Function



Ellerinize sağlık. Harika oldu
Kullanıcı avatarı
hadromer
Yeni Başlamış
 
Kayıt: 05 Kas 2017 21:44
Meslek: Ogrenci
Yaş: 29
İleti: 72
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: ankara

Cevap: Cevap: Cevap: Excel Sayfalarını Word Tablo aktarmak

İleti#28)  muzos80 » 16 Eyl 2022 14:51

hadromer yazdı:
muzos80 yazdı:makronun " With .Borders(wdBorderLeft " kısmında hata veriyor

Dosyanızı paylaşabilir misiniz kontrol edeyim



Örnek dosyam yokda ben deneme yapayım dedim ama hata verdi, ben bundaki yanlış anladıysam düzeltin aktif excel sayfamı word dosyasına aktarıyor gibi anladım
Kullanıcı avatarı
muzos80
Siteye Alışmış
 
Kayıt: 10 Arl 2016 23:14
Meslek: TPM
Yaş: 49
İleti: 207
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: istanbul/kartal

Cevap: Excel Sayfalarını Word Tablo aktarmak

İleti#29)  Yken » 16 Eyl 2022 18:01

Hata için
Alt+F11 / Tools / Reference ile Microsoft Word XX.X Object Library EKLENECEK
Dosya örnekleri ilk mesajda
Kullanıcı avatarı
Yken
Yeni Başlamış
 
Kayıt: 07 Kas 2014 11:06
Meslek: Muhasebe
Yaş: 56
İleti: 51
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Önceki

Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: Kayıtlı kullanıcı yok ve 3 misafir

Bumerang - Yazarkafe