Question

我想将karai1.xlsx的A列复制到wipbuj2.xlsx的A列，然后运行以下宏将信息复制到Word文档。然后我想通过将karai1.xlsx的B列复制到wipbuj2.xlsx的A列并运行copy-to Word宏来重复此操作。然后是karai1.xlsx等的C列，直到我到达一个空白列。下面是我尝试复制第一列。

我需要的是：从工作簿中复制列karai1.xlsx粘贴到工作簿wipbuj2.xlsx中的A（第1列）运行宏/代码

Dim wdApp As Object
Dim wd As Object
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
    Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0

Set wd = wdApp.Documents.Add


wdApp.Visible = True

Sheets("Sheet5").Select
Range("A1:g39").Select
Selection.Copy

wdApp.Selection.PasteExcelTable False, False, True
wd.SaveAs
wd.Close
wdApp.Quit

然后从工作簿中复制第2列karai1.xlsx在wippuj2.xlsx中粘贴一个列运行宏运行此循环直到工作表karai1.xlsx中的空白列。

请帮忙。

这是我正在使用的代码

enter code here 
Workbooks.Open Filename:="C:\Users\DO\Desktop\WIP buj 2.xlsx"
ActiveWindow.ScrollWorkbookTabs Sheets:=-1
Sheets("calculations").Select
Workbooks.Open Filename:= _
    "C:\Users\do\Desktop\desktop\karai data\KARAI 1.xlsx"

Range("A1:A177").Select
Selection.Copy
Windows("WIP buj 2.xlsx").Activate
Sheets("calculations").Select
Range("A1").Select
ActiveSheet.Paste
Dim wdApp As Object
Dim wd As Object
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
    Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0

Set wd = wdApp.Documents.Add


wdApp.Visible = True

Sheets("Sheet5").Select
Range("A1:g39").Select
Selection.Copy

wdApp.Selection.PasteExcelTable False, False, True
wd.SaveAs
wd.Close
wdApp.Quit

Answer 1

我相信通过在每列上添加一个简单的循环，当第1行中的单元格为空时停止，你应该能够实现你所追求的目标。

重构代码：

Sub test()
    Dim wbSrc As Workbook
    Dim wbDst As Workbook
    Dim wsSrc As Worksheet
    Dim wsDst As Worksheet
    Dim wsCpy As Worksheet
    Dim c As Long

    Dim wdApp As Object
    Dim wd As Object
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    wdApp.Visible = True

    Set wbDst = Workbooks.Open(Filename:="C:\Users\DO\Desktop\WIP buj 2.xlsx")
    Set wsDst = wbDst.Worksheets("calculations")
    Set wsCpy = wbDst.Worksheets("Sheet5")
    Set wbSrc = Workbooks.Open(Filename:="C:\Users\do\Desktop\desktop\karai data\KARAI 1.xlsx")
    Set wsSrc = ActiveSheet ' Would be better to define this explicitly using the sheet name

    c = 1
    Do While Not IsEmpty(wsSrc.Cells(1, c).Value)
        wsSrc.Cells(1, c).Resize(177, 1).Copy wsDst.Range("A1")

        'Copy to Word
        'Create new document
        Set wd = wdApp.Documents.Add
        'Copy Excel data
        wsCpy.Range("A1:g39").Copy  'Avoid Excel's "Select" whenever possible!
        'Paste in Word
        wdApp.Selection.PasteExcelTable False, False, True
        'Save and close
        wd.SaveAs
        wd.Close

        'Next column
        c = c + 1
    Loop

    wdApp.Quit
End Sub

选择范围复制粘贴运行宏清除循环直到空白列，

1 个答案: