View Single Post
 
Old 09-14-2017, 03:18 PM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,467
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Try something along the lines of:
Code:
Sub Export_Click()
Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook, r As Long
Dim xlWkSht1 As Excel.Worksheet, xlWkSht2 As Excel.Worksheet, x As Long
With xlApp
  'Hide our Excel session
  .Visible = True 'False
  'Open the workbook
  Set xlWkBk = .Workbooks.Open("C:\Users\nithomas\OneDrive - UNCG\Autofill Database Test 4.xlsx", AddToMRU:=False)
  Set xlWkSht1 = xlWkBk.Sheets("Master Database")
  'Find the next available row
  r = xlWkSht1.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
  'Do set-up for secondary sheet
  Select Case ActiveDocument.SelectContentControlsByTitle("PID Concentration")(1).Range.Text
    Case "K-12 Deaf and Hard of Hearing Teaching Licensure"
      Set xlWkSht2 = xlWkBk.Sheets("Deaf and Hard of Hearing")
      'Find the next available row
      x = xlWkSht2.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
    Case "Advocacy and Services for the Deaf"
      Set xlWkSht2 = xlWkBk.Sheets("Advocacy and Services")
      'Find the next available row
      x = xlWkSht2.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
    Case "Interpreter Preparation"
      Set xlWkSht2 = xlWkBk.Sheets("Interpreter Preparation")
      'Find the next available row
      x = xlWkSht2.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
    Case Else: Set xlWkSht2 = Nothing
    End Select
  'Update the workbook
  With ActiveDocument
    xlWkSht1.Range("B" & r).Value = .SelectContentControlsByTitle("Student Name")(1).Range.Text
    xlWkSht1.Range("C" & r).Value = .SelectContentControlsByTitle("PID Concentration")(1).Range.Text
    xlWkSht1.Range("D" & r).Value = .SelectContentControlsByTitle("Second Degree")(1).Range.Text
    xlWkSht1.Range("E" & r).Value = .SelectContentControlsByTitle("First Degree")(1).Range.Text
    xlWkSht1.Range("F" & r).Value = .SelectContentControlsByTitle("Associates of Arts")(1).Range.Text
    xlWkSht1.Range("G" & r).Value = .SelectContentControlsByTitle("Associates of Applied Science")(1).Range.Text
    xlWkSht1.Range("H" & r).Value = .SelectContentControlsByTitle("Bachelor of Arts")(1).Range.Text
    xlWkSht1.Range("I" & r).Value = .SelectContentControlsByTitle("Master of Arts")(1).Range.Text
    xlWkSht1.Range("J" & r).Value = .SelectContentControlsByTitle("Doctor of Philosophy")(1).Range.Text
    xlWkSht1.Range("K" & r).Value = .SelectContentControlsByTitle("Other")(1).Range.Text
    If Not xlWkSht2 Is Nothing Then
      'do whatever output is required for the secondary sheet. For example:
      xlWkSht2.Range("B" & x).Value = .SelectContentControlsByTitle("Student Name")(1).Range.Text
      xlWkSht2.Range("C" & x).Value = .SelectContentControlsByTitle("Second Degree")(1).Range.Text
    End If
 End With
  ' Save & Close the Excel workbook
  xlWkBk.Close SaveChanges:=True
  .Quit
End With
' Release object memory
Set xlWkSht1 = Nothing: Set xlWkSht2 = Nothing: Set xlWkBk = Nothing: Set xlApp = Nothing
' Tell the user we're done.
MsgBox "Workbook updates finished.", vbOKOnly
End Sub
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote