Question

我需要在执行以下操作的工作表中按下按钮：

在当前工作表中复制单元格D9：D20的值 - 名为“userinput”
将复制的值插入名为“stats”的工作表上名为statistics.xlsx的另一个（未打开的）excel文件中。这些值应附加在B到M列的新行上（就像数据库中的新帖子一样）

我在“Windows秘密”上找到了这个代码，看起来它可以做我需要的东西，但我不知道如何让它工作。希望有些天才可以帮助我：

    Public Sub TransferData()
    '----------------------------------------------
    'DECLARE AND SET VARIABLES
    Dim FilePath As String
    Dim I As Integer, J As Integer
    FilePath = "E:\statistics.xlsx"
    '----------------------------------------------
    'CHECK IF STATISTICS FILE IS OPEN
        '------------------------------------------
        'OPEN- SCHEDULE RECHECK
        If FileAlreadyOpen(FilePath) = True Then
            Application.OnTime Now + TimeValue("00:01:00"), "TransferData"
            Worksheets("userinput").CommandButton1.Enabled = False
            Worksheets("userinput").CommandButton1.Caption = "Saving... Please wait"
        '------------------------------------------
        'CLOSED- OPEN STATISTICS WORKBOOK AND COPY DATA
        Else:
            Workbooks.Open (FilePath)
'this row is showing up red in my VB editor - I also need the current worksheet to work without a specific filename....            
With Workbooks("statistics.xlsx").Worksheets("Stats NewRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            Workbooks("Flat File.xlsm").Activate    
            LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 

            'the following code I need to change to my needs:
            For I = 2 To LastRow
                For J = 1 To 7
                    .Cells(NewRow, J) = Cells(I, J)
                Next J
            NewRow = NewRow + 1
            Next I
            End With
        '------------------------------------------
        'SAVE, AND CLOSE GLOBAL WORKBOOK
            Worksheets("userinput").CommandButton1.Enabled = True
            Worksheets("userinput").CommandButton1.Caption = "Transfer Data"
            Workbooks("statistics.xlsx").CloseChanges:=True
            MsgBox "Global Journal updated"
        End If
    End Sub


    Function FileAlreadyOpen(FullFileName As String) As Boolean
    'http://www.exceltip.com/files-workbook-and-worksheets-in-vba/determine-if-a-file-is-in-use-using-vba-in-microsoft-excel.html
    Dim f As Integer
        f = FreeFile
        On Error Resume Next
        Open FullFileName For Binary Access Read Write Lock Read Write As #f
        Close #f
        If Err.Number <> 0 Then
            FileAlreadyOpen = True
            Err.Clear
        Else
            FileAlreadyOpen = False
        End If
        On Error GoTo 0
    End Function

Answer 1

我相信以下代码可以满足您的需求，只需检查并替换所需的代码：

Sub TransferData()
    Dim xRet As Boolean
    Dim FilePath As String
    ThisWorkbook.Worksheets("userinput").Range("D9:D20").Copy
    'above copy the range to transfer
    FilePath = "E:\statistics.xlsx"
    'set the path to the file
    xRet = IsWorkBookOpen(FilePath)
    'check if workbook is open
    If Not xRet Then 'if not open do the following
        Workbooks.Open (FilePath)
    End If
    'transfer data below
    With Workbooks("statistics.xlsx").Worksheets("Stats")
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        ID = ThisWorkbook.Worksheets("userinput").Range("E3")

        For icounter = 1 To LastRow
            If .Cells(icounter, 1) = ID Then FoundID = icounter 'loop to find the E3/ID
        Next icounter

        If FoundID <> "" Then 'if found
            .Range("B" & FoundID).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            .Range("A" & FoundID) = ThisWorkbook.Worksheets("userinput").Range("E3")
        Else 'if not found then add to next free row
            .Range("B" & LastRow + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            .Range("A" & LastRow + 1) = ThisWorkbook.Worksheets("userinput").Range("E3")
        End If
    End With
    FoundID = ""
Workbooks("statistics.xlsx").Close SaveChanges:=True
End Sub

Function IsWorkBookOpen(Name As String) As Boolean
    Dim xWb As Workbook
    On Error Resume Next
    Set xWb = Application.Workbooks.Item(Name)
    IsWorkBookOpen = (Not xWb Is Nothing)
End Function

将活动工作簿中的数据复制到统计工作簿

1 个答案: