word作成２

Sub EXCEL_WORD02() ''EXCELシートに記載している文書をWordへ転記します。
 
 
    Dim WordApp As Object
    Dim WordDoc As Word.Document
    Dim i, lRow As Long
    Dim ExcelText
    Set WordApp = CreateObject("Word.Application")  ' CreateObject関数でWordをセット
                      
    With WordApp
            .Visible = True 'Wordを起動する（表示）
            .Documents.Add 'Wordを新規作成
            
            .Selection.PageSetup.TopMargin = MillimetersToPoints(12.7)
            .Selection.PageSetup.BottomMargin = MillimetersToPoints(12.7)
            .Selection.PageSetup.LeftMargin = MillimetersToPoints(12.7)
            .Selection.PageSetup.RightMargin = MillimetersToPoints(12.7)
            
            
            '段落前後のスペースを操作する
            .Selection.ParagraphFormat.LineUnitAfter = 0
            .Selection.ParagraphFormat.SpaceAfter = 0
            
                
            lRow = Cells(Rows.Count, "A").End(xlUp).Row 'A列の最終行を取得します。

                For i = 1 To lRow 'A列の最終行分繰り返す。
                        ExcelText = Cells(i, "A").Text & vbLf 'EXCELA列のテキストデータを代入
                        .Selection.TypeText ExcelText '代入したテキストデータをWordへ転記
                Next i
            
    End With
    
End Sub

Sub sample1()

    Application.ScreenUpdating = False '描画停止
    
    Dim FileName As Variant
    Dim nameCSV As Variant
    Dim newCSV As Variant
    FileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*")
    
    If FileName = False Then
        Exit Sub
    End If
    
    Workbooks.Open FileName
    
    nameCSV = Dir(FileName)      'ファイル名を取得
    Set newCSV = Workbooks(nameCSV) 'ワークブックとして定義
    Set sh1st = newCSV.Worksheets("Progress") '1枚目のワークシートを定義

ThisWorkbook.Worksheets("Sheet3").Cells.Clear

If sh1st.AutoFilterMode Then
   sh1st.AutoFilterMode = False
End If
    
sh1st.Rows.Hidden = False
sh1st.Columns.Hidden = False

sh1st.Range("B5:LH5").AutoFilter Field:=2, Criteria1:=ThisWorkbook.Worksheets("Sheet1").Range("G2")
sh1st.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).EntireRow.Select
Selection.Copy ThisWorkbook.Worksheets("Sheet3").Cells(1, 1)
              
Application.DisplayAlerts = False
newCSV.Close SaveChanges:=False
Application.DisplayAlerts = True
      
            Dim i As Variant
            i = ThisWorkbook.Worksheets("Sheet3").Cells(Rows.Count, 2).End(xlUp).Row

            If i = 1 Then
                Exit Sub

            Else
            ThisWorkbook.Worksheets("Sheet1").Cells(1, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 2)
            ThisWorkbook.Worksheets("Sheet1").Cells(2, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 3)
            ThisWorkbook.Worksheets("Sheet1").Cells(3, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 32)
            ThisWorkbook.Worksheets("Sheet1").Cells(4, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 69)
            ThisWorkbook.Worksheets("Sheet1").Cells(5, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 73)
            ThisWorkbook.Worksheets("Sheet1").Cells(6, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 120)
            ThisWorkbook.Worksheets("Sheet1").Cells(7, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 121)
            ThisWorkbook.Worksheets("Sheet1").Cells(8, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 122)
            ThisWorkbook.Worksheets("Sheet1").Cells(9, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 210)
            ThisWorkbook.Worksheets("Sheet1").Cells(10, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 171)
            ThisWorkbook.Worksheets("Sheet1").Cells(11, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 172)
            ThisWorkbook.Worksheets("Sheet1").Cells(12, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 173)
            ThisWorkbook.Worksheets("Sheet1").Cells(13, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 174)
            ThisWorkbook.Worksheets("Sheet1").Cells(14, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 175)
            ThisWorkbook.Worksheets("Sheet1").Cells(15, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 176)
            ThisWorkbook.Worksheets("Sheet1").Cells(16, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 177)
            ThisWorkbook.Worksheets("Sheet1").Cells(17, 3) = ThisWorkbook.Worksheets("Sheet3").Cells(5, 247)

            ThisWorkbook.Worksheets("Sheet1").Cells(1, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 2)
            ThisWorkbook.Worksheets("Sheet1").Cells(2, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 3)
            ThisWorkbook.Worksheets("Sheet1").Cells(3, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 32)
            ThisWorkbook.Worksheets("Sheet1").Cells(4, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 69)
            ThisWorkbook.Worksheets("Sheet1").Cells(5, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 73)
            ThisWorkbook.Worksheets("Sheet1").Cells(6, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 120)
            ThisWorkbook.Worksheets("Sheet1").Cells(7, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 121)
            ThisWorkbook.Worksheets("Sheet1").Cells(8, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 122)
            ThisWorkbook.Worksheets("Sheet1").Cells(9, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 210)
            ThisWorkbook.Worksheets("Sheet1").Cells(10, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 171)
            ThisWorkbook.Worksheets("Sheet1").Cells(11, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 172)
            ThisWorkbook.Worksheets("Sheet1").Cells(12, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 173)
            ThisWorkbook.Worksheets("Sheet1").Cells(13, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 174)
            ThisWorkbook.Worksheets("Sheet1").Cells(14, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 175)
            ThisWorkbook.Worksheets("Sheet1").Cells(15, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 176)
            ThisWorkbook.Worksheets("Sheet1").Cells(16, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 177)
            ThisWorkbook.Worksheets("Sheet1").Cells(17, 4) = ThisWorkbook.Worksheets("Sheet3").Cells(i, 247)
            
            ThisWorkbook.Worksheets("Sheet1").Cells(6, 4) = Format(ThisWorkbook.Worksheets("Sheet1").Cells(6, 4), "yyyy/m/d")
            ThisWorkbook.Worksheets("Sheet1").Cells(7, 4) = Format(ThisWorkbook.Worksheets("Sheet1").Cells(7, 4), "yyyy/m/d")
            ThisWorkbook.Worksheets("Sheet1").Cells(9, 4) = Format(ThisWorkbook.Worksheets("Sheet1").Cells(9, 4), "yyyy/m/d")
            ThisWorkbook.Worksheets("Sheet1").Cells(17, 4) = Format(ThisWorkbook.Worksheets("Sheet1").Cells(17, 4), "yyyy/m/d")

            End If
                
    Application.ScreenUpdating = True
    
End Sub