Yazılan Bir Kodda Değişlik Yapmak

[hadromer]

Merhaba,
Daha önceden hazırlanmış olan bir kod kullanıyorum. Kod istediğim gibi çalışıyordu ancak bazı değişiklikler yapmak zorunda kaldım. Dolayısıyla istediğim değişiklikleri bu koda uygulamak istiyorum.
Kod bu linkteki dosyalar için hazırlanan bir kod. https://www.excel.web.tr/threads/excel-sayfalarini-word-tablosuna-aktarmak.203063/

6 sütunlu bir excel sayfası var. Ben bir sütun daha ekledim. ( 2 numaralı sorum için )

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.
4-) Son olarak word tablo hali fotoğraftaki gibidir. Kod bu tabloyu oluşturuyor. Ancak Bazı tablolarda satır sayısı çok olduğu için ikinci sayfaya taşıyor. Ben taşma olursa renkli tablo başlığı (Divizyo, tür...) taşan sayfanında başına gelsin istiyorum.
Yardımlarınız için şimdiden teşekkür ederim.

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 = -553582797
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

 

[hadromer]

4 numaralı talebimde word tablo başlığında manuel olarak üst bilgi satırını yineleden yapabiliyorum ancak aynı dosyada 400 tane tablo var.. bunun için bir makro oluşturulabilir mi ?

 

[hadromer]

Bu konudaki problemim çözülmüştür. Teşekkür ederim.