Question

美好的一天，

我有一张表要求用户输入数据，然后单击按钮将数据保存到数据库中。该数据库当前位于同一工作簿中＃34;不同的工作表＆＃34;。

我基本上需要的是将这些数据保存在我称之为＃34; Consolidated.xlsx＆＃34;的不同工作表上。它可以在不同的文件夹中找到＆＃34; C：/reports/consolidates.xlsx"这样我才能访问这些数据而没有其他人

如果您能提供帮助，请告诉我

目前可通过以下链接获取的文件： www.dropbox.com/s/3wea245lmek8hef/FormSheet.xls

由于

Answer 1

编辑4/19：以下代码已更新，以写入本地“PartsData”表以及合并目标...您仍需要确保“合并”文件中有一张表，即命名为“PartsData”：

Option Explicit
Sub UpdateLogWorksheet()

Dim historyWks As Worksheet, localWks As Worksheet, _
    inputWks As Worksheet, indexWks As Worksheet
Dim historyWb As Workbook
Dim MyWorksheets As New Collection
Dim nextRow As Long, oCol As Long
Dim myRng As Range, myCell As Range
Dim myCopy As String

'cells to copy from Input sheet - some contain formulas
myCopy = "D5,D7,D9,D11,D13"

'assign variables for easy reference
Set inputWks = ThisWorkbook.Worksheets("Input")
Set localWks = ThisWorkbook.Worksheets("PartsData")
Set historyWb = Workbooks.Open("C:\reports\consolidated.xlsx")
Set historyWks = historyWb.Worksheets("PartsData")

'put both target worksheets into a collection for an easy loop
MyWorksheets.Add Item:=localWks
MyWorksheets.Add Item:=historyWks

With historyWks
    nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With

With inputWks
    Set myRng = .Range(myCopy)
    If Application.CountA(myRng) <> myRng.Cells.Count Then
        MsgBox "Please fill in all the cells!"
        Exit Sub
    End If
End With

'write results of form to both local parts data and consolidated parts data
For Each indexWks In MyWorksheets
    With indexWks
        With .Cells(nextRow, "A")
            .Value = Now
            .NumberFormat = "mm/dd/yyyy hh:mm:ss"
        End With
        .Cells(nextRow, "B").Value = Application.UserName
        oCol = 3
        For Each myCell In myRng.Cells
            indexWks.Cells(nextRow, oCol).Value = myCell.Value
            oCol = oCol + 1
        Next myCell
    End With
Next indexWks

historyWb.Save '<~ save and close the target workbook
historyWb.Close SaveChanges:=False

'clear input cells that contain constants
With inputWks
  On Error Resume Next
     With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
          .ClearContents
          Application.GoTo .Cells(1) ', Scroll:=True
     End With
  On Error GoTo 0
End With
End Sub

EXCEL将数据保存到不同的工作簿 - VBA

1 个答案: