Question

通常在工作簿之间复制数据是一项相当简单的任务，但是我一直遇到这样的问题，我认为这是我查找数据或将其插入目标文件的方式的结果。我有一个.iqy文件，它给我一个包含我的SharePoint站点上所有工作簿及其文件路径的列表。然后我的代码将来自此查询的信息一起拼接，以便为我提供一个文件路径，以跟踪我需要从中收集信息的工作簿。此宏将打开每个文件，获取预期信息，并将其输出到我正在运行宏的原始文件中。对于一个信息点，我试图复制标题下面的单元格内容（它改变了我正在搜索的文件版本之间的位置）并将其粘贴到输出行中。它应该在公式中识别具有唯一单词（“Herstellkosten”）的单元格并复制其下面的值。我已经以多种方式测试了代码，并认为它找到了正确的单元格来复制然后找到要粘贴的正确单元格，但每次都没有数据出现。任何想法为什么会这样？另外，请原谅我下面的代码中的额外血腥，我仍在努力从我基于此的代码中删除不需要的部分。

Option Explicit
Dim strMasterWorkbook As String
Dim strLinkWbk As String
Dim strImportSheet As String
Dim strQueryPath As String
Dim strCurrentFilePath As String
Dim strFileName As String
Dim strCurrentFile As String
Dim intLine As Integer
Dim intExtLine As Integer
Dim intFound As Integer
Dim intSheets As Integer
Dim intLastLine As Integer
Dim dtCurrentFileModified As Date
Dim intLastLine2 As Integer
Dim intLine2 As Integer
Dim intImport As Integer
Dim intLoc As Integer
Dim strCurrentLocation As String
Dim countentry, countfound, n As Integer
Dim count_intLastLine_n1, intFound_n1, intLastLine_n1 As Integer
Dim fst_Del_Date, Org_Date, MufCost_Part, MufCost_Tool, Hours_PPP, Part_num, Planer_name, Description As Variant
Dim strFirstAddress As String
Dim searchlast As Range
Dim sht As Worksheet
Dim lastRow As Long
Dim search As Range
Dim FolderNme As String
Dim filepath As String
Dim rngFindValue As Variant

'Yellow
Sub Marine()
MsgBox "Update may take several minutes. Select OK to continue."
On Error Resume Next

'Clear Old Data
Sheets("Data").Select
Range("A2:I100000").Select
Selection.ClearContents
Sheets("Data").Select
Range("K2:Z100000").Select
Selection.ClearContents
Range("A2").Select

Dim Worksheet As Object
Dim Workbook As Object
Dim FldrWkbk As Object
Dim FolderNme As String
Dim filepath As String
Dim OutputRow As Integer
Dim StartRange As String
Dim EndRange As String
Dim ManuCost As Range
Dim header As Range, headers As Range
Set headers = sht("Project-Overview").Range("A3:Z3")

strMasterWorkbook = ActiveWorkbook.Name
strImportSheet = "QueryPaths"
strQueryPath = Sheets("QueryLocation").Range("QueryLocation").Value

Sheets(strImportSheet).Select
If Not Range("A1").Value = "" Then
Cells.Select
Selection.ClearContents
End If

Workbooks.Open strQueryPath

strLinkWbk = ActiveWorkbook.Name

Selection.Copy

ThisWorkbook.Activate
Sheets(strImportSheet).Select
Sheets(strImportSheet).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Workbooks(strLinkWbk).Close SaveChanges:=False

With Sheets(strImportSheet)

filepath = strCurrentFilePath
OutputRow = 1
ThisWorkbook.ActiveSheet.Range("A" & OutputRow).Activate
OutputRow = OutputRow + 1
For intLine = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
    If VBA.Right(.Cells(intLine, 1), 4) = "xlsm" Then
        strCurrentFilePath = "https://fect/" & .Cells(intLine, 5) & "/" & .Cells(intLine, 1)
        dtCurrentFileModified = .Cells(intLine, 2)
        intLoc = 0
        strFileName = ThisWorkbook.Worksheets("QueryPaths").Cells(intLine, 1)
        Set FldrWkbk = Workbooks.Open(strCurrentFilePath, False, True)

        For Each sht In FldrWkbk.Sheets
        ActiveWorkbook.ActiveSheet.Unprotect
'Cal Sheets
          If sht.Name Like "Cal Sheet*" Then

            'Tool Price
            ThisWorkbook.Worksheets("Data").Range("N" & OutputRow) = sht.Range("C12")
            'RFQ or POCS
            ThisWorkbook.Worksheets("Data").Range("T" & OutputRow) = sht.Range("I4")
            'Part Piece Price
'-------------------Part of Code in Question-------------------------
            Cells.Find(What:="*Herstellkosten*", LookIn:=xlFormulas).Select
            Selection.Offset(1, 0).Select
            Selection.Copy
            ThisWorkbook.Worksheets("Data").Range("O" & OutputRow).PasteSpecial xlPasteValues
'-------------------------------------------------------------------------
            OutputRow = OutputRow + 1
          End If

            Next sht
            FldrWkbk.Close SaveChanges:=False
        End If
        Application.CutCopyMode = False
    Next
End With
'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' Starting Position
Sheets("PlannerData").Select
Range("B2").Select
MsgBox "Update Complete"

End Sub

Excel VBA-将数据复制到另一个工作簿

0 个答案: