I can get my code to open the selected cells PDF. How can I loop this to run from A9 to finalrow? This is what I have working but only for selected cell.
Function OpenAnyFile(strPath As String)
Set objShell = CreateObject("Shell.Application")
objShell.Open (strPath)
End Function
Sub Cutsheets()
Application.ScreenUpdating = False
On Error GoTo whoa
Dim ordersheet As Worksheet
Dim I As Integer
Dim finalrow As Integer
Dim pdfPath As String
Set ordersheet = Sheet1
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
pdfPath = "P:\ESO\1790-ORL\OUC\_Materials\Material Cutsheets\" & ActiveCell & ".pdf"
'loop through the rows to find PDFs
For I = 9 To finalrow
If Cells(I, 1) = Application.Intersect(ActiveCell, Range("A9:A" & finalrow)) Then
Call OpenAnyFile(pdfPath)
End If
ordersheet.Select
Next I
whoa:
Exit Sub
Application.ScreenUpdating = True
End Sub
Sub Cutsheets()
Application.ScreenUpdating = False
On Error GoTo whoa
Dim I As Integer
Dim finalrow As Integer
Dim pdfPath As String
'loop through the rows to find PDFs
With Sheet1
finalrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For I = 9 To finalrow
pdfPath = "P:\ESO\1790-ORL\OUC\_Materials\Material Cutsheets\" & Cells(I, 1).Value & ".pdf"
Call OpenAnyFile(pdfPath)
Next I
End With
whoa:
Application.ScreenUpdating = True
End Sub
Related
I get a
Type Mismatch Error "13"
with the below code. Can anyone assist with where I'm going wrong with my VBA syntax and use of variables.
If Application.WorksheetFuntion.CountIf(Target, r.Value) > 1 Then
I've tried the matchFoundIndex code method to no success...Likely due to incorrect VBA syntax.
The intent of the CountIf line is to look for duplicates in column A. The rest of the code loops through files and worksheets copying the file name, worksheet name, and cell C1 for further analysis. I am a novice at coding and I'm sure there may be Dimmed variables that I'm not using, other formatting, and errors that I have not found yet. Any Help would be appreciative.
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
End If
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
If you want to check for Duplicates in a Range, you can use a Dictionary object.
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
For Each r In Target
If Trim(r.Value) <> "" Then
If Not Dict.exists(r.Value) Then ' not found in dictionary >> add Key
Dict.Add r.Value, r.Value
FindDuplicates = False
Else ' found in Dictionary >> Exit
FindDuplicates = True
Exit For
nd If
End If
Next r
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
I was having a similar experience using CountIF and passing it a range. In my case I was using:
i = Application.WorksheetFunction.CountIf(ws.UsedRange, r.Value)
which was giving me a Type Mismatch error. I had seen other people having success with the first parameter wrapped in Range() so after a few tries I found out that this would work:
i = Application.WorksheetFunction.CountIf(Range(ws.UsedRange.Address), r.Value)
So, I suggest that you change your code to this and see if it works:
If Application.WorksheetFuntion.CountIf(Range(Target.Address), r.Value) > 1 Then
I've written the following code which iterates though my worksheets of my main workbook, checks for a conditional, and then if that conditional is satisfied it copies the active worksheet into a new workbook and saves it. However, I would like to just append the worksheet to the other notebook.
Sub Archive_Sheets()
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Dim SrchRng As Range, cel As Range
Set SrchRng = ws.Range("C9:C108")
Dim bought_amt As Integer
Dim called_amt As Integer
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If InStr(1, cel.Value, "BOUGHT") > 0 Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If InStr(1, cel.Value, "CALLED") > 0 Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
ws.Range("A1").Value = "DONE"
Module8.CopySheet
Exit For
'ws.Delete
End If
Next
End Sub
Sub CopySheet()
Application.DisplayAlerts = False
Dim wb_name_arr() As String
pName = ActiveWorkbook.Path
wbName = ActiveWorkbook.Name ' the file name of the currently active file
shtName = ActiveSheet.Name ' the name of the currently selected worksheet
wb_name_arr() = Split(wbName, ".")
Application.ScreenUpdating = False
ActiveSheet.Select
ActiveSheet.Copy
' NEED TO CHANGE THIS LINE ********************
ActiveSheet.SaveAs Filename:=pName + "\" + wb_name_arr(0) + " archived.xlsx"
'****************************
Application.ScreenUpdating = True
End Sub
The code above will overwrite the new workbook I'm saving to so it's only the most recent sheet. I will already have this workbook created, so if I can append active worksheets to it that would be ideal. I already tried
ActiveSheet.Copy After:=Workbook(pName + "\" + wb_name_arr(0) + " archived.xlsx")
and
ActiveSheet.Copy Before:=Workbooks.Open(pName + "\" + wb_name_arr(0) + " archived.xlsx").Sheets(0)
with no luck.
These line are pseudo-codes. The general idea is Implicit None. Try to explicitly reference to workbooks and sheets instead of activating them. Which is also faster.
Try to avoid using ActiveSheet in your code. Simply try something like this:
Set mySht = ActiveSheet 'This should be set at the beginning of your code
Then whenever you have that Sheet (i.e. ActiveSheet) in your code, use oSht instead.
So, you need to open the Workbook to be able to work on it. Similarly, you can assign a name to different workbooks like this:
Set myWbk = ActiveWorkbook
'Or
Set oWbk = Workbooks("Output.xlsx")
What #A.S.H proposed then works for you like this:
oFile = "Path/to/the/File/" & wb_name_arr(0) & " archived.xlsx"
Set oWbk = Workbooks.Open(oFile)
mySht.Copy Before:=Workbooks(oWbk).sheets(1)
Private Sub that()
Dim aRR As Variant
aRR = ThisWorkbook.Sheets("Sheet1").UsedRange
Dim colC As Long
Dim rowC As Long
colC = ThisWorkbook.Sheets("Sheet1").UsedRange.Columns.Count
rowC = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count
ThisWorkbook.Sheets("Sheet2").Range(ThisWorkbook.Sheets("Sheet2").Cells(1, 1), ThisWorkbook.Sheets("Sheet2").Cells(rowC, colC)).Value2 = aRR
End Sub
Try edited code (I've edited both Subs to make them shorter, and also faster as there is no need to use Select and Activate).
Explanation inside the code as comments.
Option Explicit
Sub Archive_Sheets()
Dim SrchRng As Range, cel As Range
Dim bought_amt As Long
Dim called_amt As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
With ws
Set SrchRng = .Range("C9:C108")
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If cel.Value Like "BOUGHT*" Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If cel.Value Like "CALLED*" Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
.Range("A1").Value = "DONE"
CopySheet .Name ' <-- call the function and send the current ws sheet's name
Exit For
End If
End With
Next
End Sub
'==================================================================
Sub CopySheet(wsName As String)
Application.DisplayAlerts = False
Dim wb_name_arr() As String
Dim wb As Workbook
Dim pName As String, wbName As String
pName = ActiveWorkbook.Path
wb_name_arr() = Split(wbName, ".")
Application.ScreenUpdating = False
On Error Resume Next
Set wb = Workbooks(wb_name_arr(0) & " archived.xlsx") ' try to set wb if it's already open
On Error GoTo 0
If wb Is Nothing Then ' <-- wb is Nothing, means it's still close, open it
Set wb = Workbooks.Open(Filename:=pName & "\" & wb_name_arr(0) & " archived.xlsx")
End If
' === Copy the sheet to "archived" file one before tha last sheet ===
Worksheets(wsName).Copy before:=wb.Sheets(wb.Sheets.Count)
Application.ScreenUpdating = True
End Sub
Full code that solves problem.
Sub Archive_Sheets()
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Dim SrchRng As Range, cel As Range
Set SrchRng = ws.Range("C9:C108")
Dim bought_amt As Integer
Dim called_amt As Integer
bought_amt = 0
called_amt = 0
For Each cel In SrchRng
If InStr(1, cel.Value, "BOUGHT") > 0 Then
bought_amt = bought_amt + cel.Offset(0, 1).Value
End If
If InStr(1, cel.Value, "CALLED") > 0 Then
called_amt = called_amt + cel.Offset(0, 1).Value
End If
Next cel
If called_amt = bought_amt Then
If called_amt <> 0 Then
ws.Range("A1").Value = "DONE"
Module8.CopySheet
'ws.Delete
End If
End If
Next
End Sub
Sub CopySheet()
Application.DisplayAlerts = False
Dim wb_name_arr() As String
pName = ActiveWorkbook.Path
wbName = ActiveWorkbook.Name ' the file name of the currently active file
shtName = ActiveSheet.Name ' the name of the currently selected worksheet
wb_name_arr() = Split(wbName, ".")
Set mySht = ActiveSheet 'This should be set at the beginning of your code
Set myWbk = ActiveWorkbook
oFile = pName & wb_name_arr(0) & " archived.xlsx"
Set oWbk = Workbooks.Open("path_to_file")
mySht.Copy after:=oWbk.Sheets(oWbk.Sheets.Count)
oWbk.Save
End Sub
Try something like this (to make it simple for the moment, I insert the sheet at beginning):
ActiveSheet.Copy Before:=Workbooks(wb_name_arr(0) & " archived.xlsx").sheets(1)
This works if the destination WB was already open. You may want to open the WB if it is not open yet. Use the following sub to create or open the destination WB:
Sub archiveSheet(ws as Worksheet)
Dim destName As String
destName = left(ThisWorkbook.name, InStrRev(ThisWorkbook.name, ".") - 1) & " archived.xlsx"
Application.DisplayAlerts = False: Application.ScreenUpdating = False
On Error Resume Next
Dim destWB As Workbook: Set destWB = Workbooks(destName)
If destWB Is Nothing Then Set destWB = Workbooks.Open(ThisWorkbook.path + "\" & destName)
If destWB Is Nothing Then
Set destWB = Workbooks.Add
destWB.SaveAs ThisWorkbook.path & "\" & destName
End If
If destWB Is Nothing Then
msgBox "could not open or create " & destName
Else
ws.Copy After:=destWB.Sheets(destWB.Sheets.count)
End If
Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub
Call it from the main routine Archive_Sheets like this:
archiveSheet ws
I would like to write a code which open more than one .xlsx files, depending the conditions. I wrote this one:
Sub Macro()
Dim ColumnNumb As Integer
Dim FileName(14 To 16) As String
Dim i As Integer
ColumnNumb = 2
For i = 14 To 16
FileName(i) = Cells(i, 1).Value
If Workbooks("Book1.xlsm").Worksheets("Input").Cells(14, ColumnNumb) = "Yes" Then
Workbooks.Open FileName:="C:\Excel\" & FileName(i), UpdateLinks:=3
'MsgBox FileName(i)
End If
Next i
End Sub
The "Workbooks.Open..." line which is not working. However I use only the next line (MsgBox) instead of "Workbooks.Open...", then it is working perfectly.
Thanks in advance
Try the code below.
Once you open the File you lose your ActiveSheet, so the line FileName(i) = Cells(i, 1).Value won't work on the second time.
Sub Macro()
Dim ColumnNumb As Integer
Dim FileName(14 To 16) As String
Dim i As Integer
Dim ThisWB As Workbook
Dim Sht As Worksheet
ColumnNumb = 2
Set ThisWB = ThisWorkbook
' I assume from your post your data is in "Input" sheet >> modify to your needs
Set Sht = ThisWB.Sheets("Input")
For i = 14 To 16
FileName(i) = Sht.Cells(i, 1).Value
If Sht.Cells(14, ColumnNumb) = "Yes" Then
Workbooks.Open FileName:="C:\Excel\" & FileName(i), UpdateLinks:=3
'MsgBox FileName(i)
End If
Next i
End Sub
I am looking for a way to get the table of contents (not created but headings available) from word and store the chapter numbers and headings on Excel. Is there a method using Excel VBA to take those headings from word doc to excel? I have searched for this but everybody suggest using paste special however I want it automated since the data from TOC is sorted into a different table in Excel afterwards.
Sub importwordtoexcel()
MsgBox ("This Macro Might Take a While, wait until next Message")
Application.ScreenUpdating = False
Sheets("Temp").Cells.Clear
'Import all tables to a single sheet
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Word
Dim jRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
If wdDoc.Tables.Count = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
Else
jRow = 0
For TableNo = 1 To wdDoc.Tables.Count
With .Tables(TableNo)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
jRow = jRow + 1
For iCol = 1 To .Columns.Count
On Error Resume Next
Sheets("Temp").Cells(jRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
On Error GoTo 0
Next iCol
Next iRow
End With
jRow = jRow + 1
Next TableNo
End If
End With
Set wdDoc = Nothing
'Takes data from temp to RTM_FD
Dim nRow As Long
Dim mRow As Long
Dim Temp As Worksheet
Dim RTM As Worksheet
Set Temp = Sheets("Temp")
Set RTM = Sheets("RTM_FD")
mRow = 16
For nRow = 1 To Temp.Rows.Count
If Temp.Cells(nRow, 1).Value = "Position" Or Temp.Cells(nRow, 1).Value = "" Then
Else
RTM.Cells(mRow, 1).Value = Temp.Cells(nRow, 1)
RTM.Cells(mRow, 2).Value = Temp.Cells(nRow, 4)
RTM.Cells(mRow, 2).Font.Bold = False
RTM.Cells(mRow, 3).Value = Temp.Cells(nRow, 5)
RTM.Cells(mRow, 3).Font.ColorIndex = 32
If Temp.Cells(nRow, 3).Value = "P" Then
RTM.Cells(mRow, 9).Value = "X"
RTM.Cells(mRow, 9).Interior.ColorIndex = 44
ElseIf Temp.Cells(nRow, 3) = "Q" Then
RTM.Cells(mRow, 7).Value = "X"
RTM.Cells(mRow, 7).Interior.ColorIndex = 44
ElseIf Temp.Cells(nRow, 3) = "TA" Then
RTM.Cells(mRow, 8).Value = "X"
RTM.Cells(mRow, 8).Interior.ColorIndex = 44
Else
End If
mRow = mRow + 1
End If
Next nRow
Application.ScreenUpdating = True
MsgBox ("DONE")
Sheets("Temp").Cells.Clear
Dim SaveName As String
SaveName = InputBox("What Do You Want to Save the File As:")
ActiveWorkbook.SaveAs (SaveName)
MsgBox ("Your file is saved as " & SaveName)
MsgBox ("Please Accept Delete Operation")
Sheets("Temp").Delete
ActiveWorkbook.Save
End Sub
One way to get section headings without creating a TOC is by iterating with the selection object, using Selection.Goto. The folowing example prints all the sections headings in a document to the immediate window. I am sure you can adapt the concept to your code.
Sub PrintHeadings()
Dim wrdApp As Word.Application
Dim wrdDoc As Document
Dim Para As Paragraph
Dim oldstart As Variant
Set wrdApp = CreateObject("Word.Application") 'open word
Set wrdDoc = wrdApp.Documents.Open("C:\sample.docx", , True, False, , , , , , , , True) 'open file
wrdDoc.ActiveWindow.ActivePane.View.Type = wdPrintView 'avoids crashing if opens on read view
With wrdDoc.ActiveWindow.Selection
.GoTo What:=wdGoToHeading, which:=wdGoToFirst 'go to first heading
Do
Set Para = .Paragraphs(1) 'get first paragraph
Title = Replace(Para.Range.Text, Chr(13), "") 'gets title and remove trailing newline
Debug.Print Title, "pg. "; .Information(wdActiveEndAdjustedPageNumber) 'prints title and page to console
oldstart = .Start 'stores position
.GoTo What:=wdGoToHeading, which:=wdGoToNext 'go to next heading
If .Start <= oldstart Then Exit Do 'if looped around to first section (i.e. new heading is before old heading) we are done
Loop
End With
wrdDoc.Close
wrdApp.Quit
Set Para = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
I use early binding, so you will need to either add a reference to Word object model, or tweak the code to late binding (including finding out the numeric value of the enums).
I worked fine with My Chinese words documents, it may require to change some of the codes for different heading style.
If it won't work for you, I would love to have your words sample file and figure out why.
PS: The key point is to have the correct #OLE_LINK format.
My codes is as follows:
' Get your file and save in Range("A1")
Public Sub SelectAFile()
Dim intChoice As Integer
Dim strPath As String
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'print the file path to sheet 1
Cells(1, 1) = strPath
End If
End Sub
' Main program start here
Sub genWordIndex()
Dim rng As Range
Dim r As Range
Dim PageName As String
Dim TestValue As String
Dim WshShell As Variant
Set WshShell = CreateObject("WScript.Shell")
Set rng = Range("A1") 'Selection
Call CleanOldText(1)
PageName = rng.text
Call ReadIndexFromWords3(PageName)
End Sub
Sub ReadIndexFromWords3(ByVal FileName As String)
'
' This is a common routine for handling open file
'
Dim WA As Object
Dim wdDoc As Word.Document
On Error Resume Next
Set WA = GetObject(, "Word.Application")
If WA Is Nothing Then
Set WA = CreateObject("Word.Application")
Set wdDoc = WA.Documents.Open(FileName)
Else
On Error GoTo notOpen
Set wdDoc = WA.Documents(FileName)
GoTo OpenAlready
notOpen:
Set wdDoc = WA.Documents.Open(FileName)
End If
OpenAlready:
wdDoc.Activate
'
' read index program start here。
'
Dim i As Integer: i = 2
Dim H_start, H_end, H_Caption, H_lvl, H_page As String
Dim H_txt As String
Dim Para As Paragraph
For Each Para In wdDoc.Paragraphs
Para.Range.Select
If Not Para.Range.Style Is Nothing Then
If IsMyHeadingStype(Para.Range.Style) = True Then
H_start = Para.Range.Start
H_end = Para.Range.End
H_txt = Para.Range.text
H_Caption = Para.Range.ListFormat.ListString
H_page = Para.Range.Information(wdActiveEndPageNumber)
Dim myLinkAddress As String
myLinkAddress = FileName & "#OLE_LINK" & i & vbTab & "1," & H_start & "," & H_end & ",2,," & H_txt
Application.ActiveWorkbook.Activate
ActiveSheet.Cells(i, 1).Select
Dim CapLen As Integer:
CapLen = Len(H_Caption) - 1
If CapLen < 0 Then CapLen = 0
ActiveSheet.Cells(i, 1) = Space(CapLen) & H_Caption & " " & H_txt
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:=myLinkAddress, SubAddress:="" 'TextToDisplay:=H_txt,
ActiveSheet.Cells(i, 2) = H_page
i = i + 1
End If
End If
Next
End Sub
'
' you may have to change your InStyle here
'
Function IsMyHeadingStype(ByVal InStyle As String) As Boolean
Dim rc As Boolean: rc = False
If InStr(InStyle, "標題 1") Or InStr(InStyle, "標題 2") Or InStr(InStyle, "標題 3") Then
rc = True
End If
IsMyHeadingStype = rc
End Function
' sub routine
Sub CleanOldText(ByVal col1 As Integer)
Dim i As Integer
Dim lastR As Integer
lastR = Cells(10000, col1).End(xlUp).Row
For i = 2 To lastR
Cells(i, col1).ClearContents
Cells(i, col1 + 1).ClearContents
Next i
End Sub
I am very new to macro programming and currently creating a macro that splits a table into new worksheets dependent on a unique variable, then copies and pastes each worksheet into a single word document split by page breaks.
What I cannot work out how to do, is create a macro that gives each table on each page a title based on the value of a cell.
Option Explicit
Sub Run_All()
Call Organise_Table
Call Rename_Column
Call Isblank
Call Split_Table
Call SumColumn
Call ExceltoWord
Call Report_Title
End Sub
Sub Organise_Table()
Columns(1).EntireColumn.Delete
Columns(1).EntireColumn.Delete
Columns(2).EntireColumn.Delete
Columns(3).EntireColumn.Delete
Columns(3).EntireColumn.Delete
End Sub
Sub Rename_Column()
Range("A1") = "Contribution Type"
Range("B1") = "RefNo"
Range("C1") = "Title"
Range("D1") = "Initals"
Range("E1") = "Surname"
Range("F1") = "Balance Brought Forward"
Range("G1") = "Annual Interest Added"
Range("H1") = "Contributions Added"
Range("I1") = "Total Fund Value"
End Sub
Sub Isblank()
Application.ScreenUpdating = False
On Error Resume Next
With Range("F1:I14")
.SpecialCells(xlCellTypeBlanks).Formula = "0"
.Value = .Value
End With
Err.Clear
Application.ScreenUpdating = True
End Sub
Sub Split_Table()
Dim lr As Long
Dim Ws As Worksheet
Dim vcol As Integer
Dim i As Integer
Dim iCol As Long
Dim myarr As Variant
Dim Title As String
Dim titlerow As Integer
vcol = 2
Set Ws = Sheets("Sheet1")
Title = "A1:I14"
Application.ScreenUpdating = False
lr = Ws.Cells(Ws.Rows.Count, vcol).End(xlUp).Row
titlerow = Ws.Range(Title).Cells(1).Row
iCol = Ws.Columns.Count
Ws.Cells(1, iCol) = "Unique"
For i = 2 To lr
On Error Resume Next
If Ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(Ws.Cells(i, vcol), Ws.Columns(iCol), 0) = 0 Then
Ws.Cells(Ws.Rows.Count, iCol).End(xlUp).Offset(1) = Ws.Cells(i, vcol)
End If
Next i
myarr = Application.WorksheetFunction.Transpose(Ws.Columns(iCol).SpecialCells(xlCellTypeConstants))
Ws.Columns(iCol).Clear
For i = 2 To UBound(myarr)
Ws.Range(Title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
Ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next i
Ws.AutoFilterMode = False
Ws.Activate
End Sub
Sub SumColumn()
Dim LastRow As Long
Dim iRow As Long
Dim iCol As Integer
Dim nSheets As Integer
For nSheets = 1 To 3
With Worksheets(nSheets)
LastRow = 0
For iCol = 6 To 9
iRow = .Cells(65536, iCol).End(xlUp).Row
If iRow > LastRow Then LastRow = iRow
Next iCol
For iCol = 6 To 9
.Cells(LastRow + 1, iCol) = Application.WorksheetFunction.Sum(Range(.Cells(1, iCol), .Cells(LastRow, iCol)))
Next iCol
iCol = 1
.Cells(LastRow + 1, iCol).Value = ("Total")
End With
Next nSheets
End Sub
Sub ExceltoWord()
Dim Ws As Worksheet
Dim Wkbk1 As Workbook
Dim strdocname As String
Dim wdapp As Object
Dim wddoc As Object
Dim orng As Object
Dim wdAutoFitwindow As String
Set Wkbk1 = ActiveWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
strdocname = "\\VDC.COM\User\HomeDrives\GFSNRE\Desktop\Test19.Doc" 'Change this to whatever directory the report will be in
'file name & folder path
On Error Resume Next
'error number 429
Set wdapp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Err.Clear
'create new instance of word application
Set wdapp = CreateObject("Word.Application")
End If
wdapp.Visible = True
'define paths to file
If Dir(strdocname) = "" Then
'MsgBox "The file" & strdocname & vbCrLf & "was not found " & vbCrLf & "C:\Path\Name.doc", _
' vbExclamation, "The document does not exist "
'Exit Sub
Set wddoc = wdapp.Documents.Add
Else
Set wddoc = wdapp.Documents.Open(strdocname)
End If
For Each Ws In Wkbk1.Worksheets
Ws.Range("A1:I14").Copy
Set orng = wddoc.Range
orng.collapse 0
orng.Paste
orng.End = wddoc.Range.End
orng.collapse 0
orng.insertbreak Type:=7
Range("A1:I14").Borders.LineStyle = xlContinuous
wddoc.AutofitBehavior wdAutoFitwindow
Next Ws
lbl_Exit:
Set orng = Nothing
Set wddoc = Nothing
Set wdapp = Nothing
Set Wkbk1 = Nothing
Set Ws = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
End Sub
Sub Report_Title()
Dim Ws As Worksheet
Dim MyText As String
Dim MyRange As Object
Set MyRange = ActiveWorkbook.Range
MyText = Ws.Range("E3").Value
' Selection Example:
Selection.InsertBefore (MyText)
' Range Example: Inserts text at the beginning
' of the active document.
MyRange.InsertBefore (MyText)
End Sub
There is one error here :
Dim Ws As Worksheet
Dim MyText As String
Dim MyRange As Object
Set MyRange = ActiveWorkbook.Range
MyText = Ws.Range("E3").Value '<==== WS is not properly defined yet
You are using Ws. to say in which worksheet you are working in, which is a good thing. But, as it is a procedure-level variable, it is not pointing anywhere useful. You probably need something like :
Set MyRange = ActiveWorkbook.Range
Set Ws = ActiveWorkbook.Sheets("Sheet1") 'assuming you want to read "E3" on the sheet "Sheet1" of the active workbook, that's the line to add
MyText = Ws.Range("E3").Value '<==== WS is now properly defined
If you go to debugging mode, you should have nothing in "MyText" in your version, and something in mine. The content of E3 in the sheet Sheet1.
Two things:
You should not turn off error handling for the entire code. If
things aren't working VBA can't tell you why or where the problem
is. While it's standar practise to use On Error Resume Next when
using GetObject/CreateObject it's also standard practise to turn
error handling back on AFTER the If...End If. You need to add the
line: On Error GoTo 0 where you have no error handler code.
Based on your sample code, write in the Title before pasting the table.
So something like this:
For Each Ws In Wkbk1.Worksheets
Ws.Range("A1:I14").Copy
Set orng = wddoc.Range
orng.collapse 0
orng.Text = Ws.Range([cell reference with title]) & vbCr
orng.collapse 0
orng.Paste
orng.End = wddoc.Range.End
orng.collapse 0
orng.insertbreak Type:=7
Range("A1:I14").Borders.LineStyle = xlContinuous
wddoc.AutofitBehavior wdAutoFitwindow
Next Ws