Posts by DLS

Dim Arr As Variant


Private Sub UserForm_Initialize()
'***change sheet name and range to suit
Arr = Sheets("sheet1").Range("A1:A10")
With UserForm1.ListBox1
.List = Arr
End With
End Sub


Private Sub TextBox1_Change()
Dim Cnt As Integer, Cnt2 As Integer
UserForm1.ListBox1.ListIndex = -1
For Cnt = 1 To Len(UserForm1.TextBox1.Text)
For Cnt2 = LBound(Arr) To UBound(Arr)
If Left(Arr(Cnt2, 1), Cnt) = UserForm1.TextBox1.Text Then
UserForm1.ListBox1.ListIndex = Cnt2 - 1
Exit Sub
End If
Next Cnt2
Next Cnt
End Sub

Sub test()
Dim WrdApp As Object, Cnt As Integer, FileStr As String, FlCnt As Integer
Dim WrdDoc As Object, TblCell As Variant, SearchWord() As Variant
Dim FSO As Object, FolDir As Object, FileNm As Object, ColCnt As Integer


'*** SearchWord is case sensitive and must be the same as the Word doc
SearchWord = Array("Name", "Husband's name", "Maternal UHID", "Age")


'start Word
On Error Resume Next
Set WrdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
On Error GoTo ErFix
Set WrdApp = CreateObject("Word.Application")
End If
WrdApp.Visible = False


FlCnt = 1
Set FSO = CreateObject("scripting.filesystemobject")
'***change directory to suit
Set FolDir = FSO.GetFolder("D:\testfolder2")
'loop files
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".docx" Then
FileStr = CStr(FileNm)
Set WrdDoc = WrdApp.Documents.Open(FileStr)
FlCnt = FlCnt + 1


'admission
Sheets("sheet1").Range("A" & FlCnt) = Right(Left(WrdApp.ActiveDocument.Paragraphs(3), 29), 10)
'discharge
Sheets("sheet1").Range("B" & FlCnt) = Right(WrdApp.ActiveDocument.Paragraphs(3), 12)


'loop through table cells
ColCnt = 2
For Cnt = LBound(SearchWord) To UBound(SearchWord)
For Each TblCell In WrdApp.ActiveDocument.Tables(1).Range.Cells
If InStr(TblCell.Range, SearchWord(Cnt)) Then
ColCnt = ColCnt + 1
Sheets("sheet1").Cells(FlCnt, ColCnt) = WrdApp.ActiveDocument.Tables(1).Cell(TblCell.RowIndex, TblCell.ColumnIndex)
'remove pilcrow
Sheets("sheet1").Cells(FlCnt, ColCnt) = Application.WorksheetFunction.Clean(Sheets("sheet1").Cells(FlCnt, ColCnt))
'remove searchword plus 2 (:_)
Sheets("sheet1").Cells(FlCnt, ColCnt) = Right(Sheets("sheet1").Cells(FlCnt, ColCnt), _
Len(Sheets("sheet1").Cells(FlCnt, ColCnt)) - (Len(SearchWord(Cnt)) + 2))
Exit For
End If
Next TblCell
Next Cnt


'close and save doc
WrdApp.ActiveDocument.Close savechanges:=False
Set WrdDoc = Nothing
End If
Next FileNm


Set FolDir = Nothing
Set FSO = Nothing
WrdApp.Quit
Set WrdApp = Nothing
MsgBox "Finished"
Exit Sub


ErFix:
On Error GoTo 0
MsgBox "error"
Set FolDir = Nothing
Set FSO = Nothing
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub

Sub test()


Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim BMRange As Word.Range
Dim company As Range
Dim address As Range
Dim address2 As Range
Dim city As Range
Dim state As Range
Dim zip As Range
Dim CuurentDate As Date
Dim Cnt As Integer
Dim LastRow As Integer


LastRow = Sheets("sheet1").UsedRange.End(xlDown).Row
Set wdApp = CreateObject("Word.Application") 'Create an instance of word


For Cnt = 2 To LastRow
Set wdDoc = wdApp.Documents.Open("C:\Documents and Settings\mwildrick\Desktop\TEST\Publisher Payment Form.dotm") 'Open word file


'now set your excel ranges
Set company = ThisWorkbook.Sheets("CompanyInfo").Range("A" & Cnt)
Set address = ThisWorkbook.Sheets("CompanyInfo").Range("B" & Cnt)
Set city = ThisWorkbook.Sheets("CompanyInfo").Range("D" & Cnt)
Set state = ThisWorkbook.Sheets("CompanyInfo").Range("E" & Cnt)
Set zip = ThisWorkbook.Sheets("CompanyInfo").Range("F" & Cnt)


'Set your word bookmark
Set BMRange = wdDoc.Goto(what:=wdGoToBookmark, Name:="company")
BMRange.Text = company


Set BMRange = wdDoc.Goto(what:=wdGoToBookmark, Name:="Address")
BMRange.Text = address


Set BMRange = wdDoc.Goto(what:=wdGoToBookmark, Name:="City")
BMRange.Text = city


Set BMRange = wdDoc.Goto(what:=wdGoToBookmark, Name:="State")
BMRange.Text = state


Set BMRange = wdDoc.Goto(what:=wdGoToBookmark, Name:="Zip")
BMRange.Text = zip


'Save your word doc
With wdApp.ActiveDocument
.SaveAs ThisWorkbook.Path & "\" & company & ".doc"
.Close
End With


Next Cnt


'Close out word
wdApp.Quit


Set BMRange = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing


End Sub

Sub XLCellToWordTableCell()
Dim oWDBasic As Object, Rng As Range, Txtstr As String
Dim wrdDoc As Object, Ocell As Variant, TC As Variant
Dim Lastrow As Integer, Lastcol As Integer, Cnt As Integer
'adds text & table to Word doc from XL
'makes Word Table and adds used range to table
'no Word reference required
     
On Error GoTo ErFix
'open existing word doc file ie. "D:\tabletest.doc"
'*** "D:\tabletest.doc" MUST exist ie. change as needed
Set oWDBasic = CreateObject("Word.Application")
Set wrdDoc = oWDBasic.Documents.Open(Filename:="D:\tabletest.doc")
     
'clear doc
With wrdDoc
    .Range(0, .Characters.Count).Delete
End With
     
'add text to top of doc and spaces before table
oWDBasic.ActiveDocument.Select
With oWDBasic.Selection
    .typetext Text:=" *** Table Test *** " & vbCrLf
    .typeparagraph
    .typeparagraph
End With
     
'determine table sixe from Xl range (used range in this eg.)
Lastrow = Sheets("Sheet1").UsedRange.Rows.Count
Lastcol = Sheets("Sheet1").UsedRange.Columns.Count
 
'add variable sized table
With wrdDoc
' insert table at current selection point
    .Tables.Add oWDBasic.Selection.Range, numrows:=Lastrow, _
    Numcolumns:=Lastcol
End With
     
'autoformat table/table options
'wdTableFormat3DEffects1 (0)
'etc
'wdTableFormatWeb3 (42)
'table autoformat #'s 0 to 42 (3 in this eg.)
oWDBasic.ActiveDocument.Tables(1).AutoFormat Format:=3, _
ApplyBorders:=True, ApplyFont:=True, ApplyColor:=True
     
'vba set XL range
With Sheets("Sheet1")
        Set Rng = .Range(.Cells(1, 1), .Cells(Lastrow, Lastcol))
End With


'insert XL cell.value to table location
Cnt = 1
For Each Ocell In Rng
Set TC = oWDBasic.ActiveDocument.Tables(1).Range.Cells(Cnt)
TC.Range.InsertAfter Ocell.Value
Cnt = Cnt + 1
Next Ocell
     
     
'fit table and add adjustments/margins
With oWDBasic.ActiveDocument.Tables(1)
.Columns.AutoFit
'.Rows.SetLeftIndent LeftIndent:=-57.6, RulerStyle:=False
'.Columns(3).SetWidth ColumnWidth:=153.3, RulerStyle:=False
'.Columns(4).SetWidth ColumnWidth:=144, RulerStyle:=False
End With
    
'carry on with remaining doc contents
'eg. make text string with space following table
Txtstr = vbCrLf & "Test finished at: " & Now()
 
'add text string after table
With oWDBasic.ActiveDocument
    .content.InsertAfter Txtstr
End With
 
'close and save doc
oWDBasic.ActiveDocument.Close savechanges:=True
 
Set wrdDoc = Nothing
oWDBasic.Quit
Set oWDBasic = Nothing
MsgBox "Finished"
Exit Sub
     
ErFix:
    On Error GoTo 0
    MsgBox "error"
    Set wrdDoc = Nothing
    oWDBasic.Quit
    Set oWDBasic = Nothing
End Sub

Sub ColorAlphCells()
'colors cells containing letters


Dim i As Integer, Temp As Integer
Dim C As Variant, Myrange As Range


'change range to suit
Set Myrange = Sheets("sheet1").UsedRange
For Each C In Myrange
    For i = 1 To Len(C.Value)
        Temp = Asc(Mid(C.Value, i, 1))
        If ((Temp > 64) And (Temp < 90)) Or _
           ((Temp > 96) And (Temp < 123)) Then
            C.Interior.ColorIndex = 5
            Exit For
        End If
    Next i
Next C
End Sub

Sub ChartLabel()
'test with sht 1 named range ("year") ...
'..sht1 listbox with selection ("Listbox1")...
'..sht1 command button ("Commandbutton1")...
'..sht1 embed chart...


Dim TempStr As String, TempStr2 As String
'make conditional string
If Sheets("Sheet1").CommandButton1.BackColor <> _
RGB(0, 128, 64) Then 'green
TempStr2 = "PLAN"
Else
TempStr2 = "ACTUAL"
End If


'make string(tempstr) to add named range, listbox txt...
'..and conditional string(tempstr2)to chart title


tempstr = Sheets("Sheet1").Range("year").Value & _
"             " + Sheets("Sheet1").ListBox1.Text + _
"             " + TempStr2


'activate chart and add string
Sheets("Sheet1").ChartObjects(1).Activate
With ActiveChart
        .HasTitle = True
        .ChartTitle.Characters.Text = tempstr
End With
End Sub