使用vba如何使用excel实现单元格复制到最后一行？ [英] How to achieve cell copy to the last row in excel using vba?

问题描述

我想复制A9中存在的数据，直到单元格A12&类似地从B9到B12。我可以将单元格A1中存在的数据成功复制到A8。但不能复制&从A9到A12& B9到B12。我的代码无法复制&粘贴最后一条记录。

  Option Explicit 
 
 Dim FSO As Object 
 Dim strFolderName As String 
 Dim FileToOpenVdocx As String 
 Dim FileToOpenvdoc1 As String 
 Dim FileToOpenVdoc As String 
 Dim FileToOpenvdocx1 As String 
 Dim wrdApp As Word.Application 
 Dim wrdDoc As Word.Document 
 Dim fsoFolder As Object 
 
'将数据从word复制到excel 
 
'将数据从word复制到excel 
 Sub FindFilesInSubFolders（）
 Dim fsoFolder As Scripting.Folder 
 Sheets（Sheet1）。Cells.Clear 
 FileToOpenVdocx =* V2.1.docx *
 FileToOpenvdoc1 =* v2.1.doc *
 FileToOpenVdoc =* V2.1.doc *
 FileToOpenvdocx1 =* v2.1.docx *
如果FSO不是，然后
设置FSO = CreateObject（Scripting.FileSystemObject）
结束如果
'设置新的子文件夹的父文件夹
 strFolderName =C：\Test1
设置fsoFolder = FSO.GetFolder（strFolderName）
设置wrdApp = CreateObject（Word.Application）
 OpenFilesInSubFolders fsoFolder 
 wrdApp.Quit 
 End Sub 
 
 Sub OpenFilesInSubFolders（fsoPFolder As Scripting.Folder）
 Dim fsoSFolder As Scripting.Folder 
 Dim fileDoc As Scripting.File 
 Dim wrdRng As Object 
 Dim strText As String 
 Dim singleLine As Object 
 Dim outRow As Long'new added 
 Dim Found As String 
 Dim resultId As String 
 Dim singleLineZ As Object 
 Dim resultIdZ As String 
 Dim row As Long 
 Dim startRow As Long 
 Dim lastRow As Long 
 Dim LRA As Long 
 Dim LRB As Long 
 Dim row2 As Long 
 
 outRow = 1'你似乎想从第一行开始
 For each fsoS文件夹在fsoPFolder.SubFolders 
对于每个fileDoc在fsoSFolder.Files 
如果（fileDoc.Name像FileToOpenVdocx或fileDoc.Name像FileToOpenvdoc1或fileDoc.Name像FileToOpenVdoc或fileDoc.Name像FileToOpenvdocx1）和左（fileDoc .Name，1）<> 〜然后
设置wrdDoc = wrdApp.Documents.Open（fileDoc.Path）
设置wrdRng = wrdDoc.Content 
对于每个singleLine在wrdApp.ActiveDocument.Paragraphs 
 Found = InStr（singleLine，Application）
如果找到> 0然后
 resultId = singleLine 
退出
结束如果
下一个单列
对于每个singleLineZ在wrdApp.ActiveDocument.Paragraphs 
 Found = InStr（singleLineZ， Z）
如果找到> 0然后
 resultIdZ = singleLineZ 
退出
结束如果
下一个singleLineZ 
带wrdApp 
 .ActiveDocument.Tables（1）。选择
 .Selection.Copy 
使用ThisWorkbook.Worksheets（Sheet1）
 startRow = .Cells（.Rows.Count，C）。End（xlUp）（2）.row 
。单元格（startRow，C）。PasteSpecial xlPasteValues 
 lastRow = .Cells（.Rows.Count，C）。End（xlUp）.row 
'将最后粘贴的表与标签
 .Range（.Cells（startRow，A），.Cells（lastRow，A））Value = resultId 
 .Range（.Cells（startRow，B）， lastRow，B））Value = resultIdZ 
结束
结束
 wrdDoc.Close False 
结束If 
下一个fileDoc 
 OpenFilesInSubFolders fsoSFolder 
 Next fsoSFolder 
 End Sub 
  

I want to copy the data present in A9, up to the cell A12 & similarly from B9 to B12. I can copy the data present in cell A1, up to A8 successfully. But cannot copy & paste from A9 to A12 & B9 to B12. My code is unable to copy & paste for the last record.

           With wrdApp
           .ActiveDocument.Tables(1).Select
           .Selection.Copy
            With ThisWorkbook.Worksheets("Sheet1")
            .Cells(Rows.Count, "C").End(xlUp)(1).PasteSpecial xlPasteValues
            'getting the last row
            lastRow = .Range("C:C").End(xlDown).row
            'loop all row in column "C" for checking
                For row = 1 To lastRow Step 1
                    'If value of C cell is "Version", check column A cell and B cell
                    If (.Range("C" & row) = "Version" Or .Range("C" & row) = "version") Then
                    'If both cell are empty, store value.
                    If .Range("A" & row) = "" And .Range("B" & row) = "" Then
                    .Range("A" & row).Value = resultId
                    .Range("B" & row).Value = resultIdZ


                    LR = Range("B" & Rows.Count).End(xlUp).row
                        With Range("B2:B" & LR)
                            With .SpecialCells(xlCellTypeBlanks)

                            End With
                            .Value = .Value
                        End With

                    LR = Range("A" & Rows.Count).End(xlUp).row
                    With Range("A2:A" & LR)
                        With .SpecialCells(xlCellTypeBlanks)
                        .FormulaR1C1 = "=R[-1]C"
                        End With
                        .Value = .Value
                    End With
                Exit For
            End If
        End If
    Next row
End With

解决方案

Here is my answer which might help someone. Prior to that, I would like to say thanks to Luuklag for helping me in a brilliant way.

Make sure that, you add the below references before proceeding.

Option Explicit

Dim FSO As Object
Dim strFolderName As String
Dim FileToOpenVdocx As String
Dim FileToOpenvdoc1 As String
Dim FileToOpenVdoc As String
Dim FileToOpenvdocx1 As String
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim fsoFolder As Object

'To copy data from word to excel

'Copy data from word to excel
Sub FindFilesInSubFolders()
Dim fsoFolder As Scripting.Folder
Sheets("Sheet1").Cells.Clear
FileToOpenVdocx = "*V2.1.docx*"
FileToOpenvdoc1 = "*v2.1.doc*"
FileToOpenVdoc = "*V2.1.doc*"
FileToOpenvdocx1 = "*v2.1.docx*"
If FSO Is Nothing Then
    Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Set the parent folder for the new subfolders
strFolderName = "C:\Test1"
Set fsoFolder = FSO.GetFolder(strFolderName)
Set wrdApp = CreateObject("Word.Application")
OpenFilesInSubFolders fsoFolder
wrdApp.Quit
End Sub

Sub OpenFilesInSubFolders(fsoPFolder As Scripting.Folder)
Dim fsoSFolder As Scripting.Folder
Dim fileDoc As Scripting.File
Dim wrdRng As Object
Dim strText As String
Dim singleLine As Object
Dim outRow As Long ' newly added
Dim Found As String
Dim resultId As String
Dim singleLineZ As Object
Dim resultIdZ As String
Dim row As Long
Dim startRow As Long
Dim lastRow As Long
Dim LRA As Long
Dim LRB As Long
Dim row2 As Long

outRow = 1 'you appear to want to start at the first row
For Each fsoSFolder In fsoPFolder.SubFolders
    For Each fileDoc In fsoSFolder.Files
        If (fileDoc.Name Like FileToOpenVdocx Or fileDoc.Name Like FileToOpenvdoc1 Or fileDoc.Name Like FileToOpenVdoc Or fileDoc.Name Like FileToOpenvdocx1) And Left(fileDoc.Name, 1) <> "~" Then
            Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path)
            Set wrdRng = wrdDoc.Content
            For Each singleLine In wrdApp.ActiveDocument.Paragraphs
                Found = InStr(singleLine, "Application")
                If Found > 0 Then
                    resultId = singleLine
                    Exit For
                End If
            Next singleLine
            For Each singleLineZ In wrdApp.ActiveDocument.Paragraphs
                Found = InStr(singleLineZ, "Z")
                If Found > 0 Then
                    resultIdZ = singleLineZ
                    Exit For
                End If
            Next singleLineZ
            With wrdApp
                .ActiveDocument.Tables(1).Select
                .Selection.Copy
                With ThisWorkbook.Worksheets("Sheet1")
                    startRow = .Cells(.Rows.Count, "C").End(xlUp)(2).row
                    .Cells(startRow, "C").PasteSpecial xlPasteValues
                    lastRow = .Cells(.Rows.Count, "C").End(xlUp).row
                    'Match the last pasted table with the labels
                    .Range(.Cells(startRow, "A"), .Cells(lastRow, "A")).Value = resultId
                    .Range(.Cells(startRow, "B"), .Cells(lastRow, "B")).Value = resultIdZ
                End With
            End With
            wrdDoc.Close False
        End If
    Next fileDoc
    OpenFilesInSubFolders fsoSFolder
Next fsoSFolder
End Sub

这篇关于使用vba如何使用excel实现单元格复制到最后一行？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！