Thread: [Solved] Excel VBA Macros
View Single Post
 
Old 07-20-2015, 02:32 AM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,344
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 the code below. I've implemented the mcrImport & mcrCombine macros. The macro assumes the National & State files are all kept in the same folder.

You still haven't provided anything relevant to the mcrValidate macro and your WelcomeAboard template, though, would be better implemented as a mailmerge main document, for which no macros would be required.

Code:
Option Explicit
Dim StrSrc As String, StrState As String, xlWkBk As Workbook, xlWkSht As Worksheet
Dim i As Long, lRowSrc As Long, lColSrc As Long, lRowTgt As Long
Sub mcrImport()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ArrState As Variant
ArrState = Array("NSW", "Vic", "Qld", "WA", "SA", "Tas", "ACT", "NT")
For i = 0 To UBound(ArrState)
  StrState = ArrState(i)
  StrSrc = ActiveWorkbook.Path & "\" & StrState & ".xls"
  If Dir(StrSrc) <> "" Then Call AddSheet(StrState, StrSrc)
Next
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub AddSheet(StrState As String, StrSrc As String)
With ActiveWorkbook
  Set xlWkSht = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
  With xlWkSht
    .Name = StrState
    'Populate the header row
    .Range("A1").Value = "Family Name"
    .Range("B1").Value = "Given Name"
    .Range("C1").Value = "Gender"
    .Range("D1").Value = "D.O.B."
    .Range("E1").Value = "Address"
    .Range("F1").Value = "Suburb"
    .Range("G1").Value = "State"
    .Range("H1").Value = "Post Code"
    .Range("I1").Value = "Role"
    Call GetData(StrSrc)
    .Paste Destination:=.Cells(2, 1)
  End With
End With
Set xlWkSht = Nothing
End Sub
Sub GetData(StrSrc As String)
Set xlWkBk = Workbooks.Open(Filename:=StrSrc, ReadOnly:=True, AddToMRU:=False)
With xlWkBk
  With .Worksheets(1).UsedRange
    lRowSrc = .Cells.SpecialCells(xlCellTypeLastCell).Row
    lColSrc = .Cells.SpecialCells(xlCellTypeLastCell).Column
    .Range("A1", .Cells(lRowSrc, lColSrc)).Copy
  End With
  .Close 0
End With
Set xlWkBk = Nothing
End Sub
Sub mcrCombine()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ArrState As Variant
ArrState = Array("NSW", "Vic", "Qld", "WA", "SA", "Tas", "ACT", "NT")
With ActiveWorkbook
  Set xlWkSht = .Worksheets.Add(After:=.Worksheets(1))
  xlWkSht.Name = "Combined"
  With xlWkSht
    'Populate the header row
    .Range("A1").Value = "Family Name"
    .Range("B1").Value = "Given Name"
    .Range("C1").Value = "Gender"
    .Range("D1").Value = "D.O.B."
    .Range("E1").Value = "Address"
    .Range("F1").Value = "Suburb"
    .Range("G1").Value = "State"
    .Range("H1").Value = "Post Code"
    .Range("I1").Value = "Role"
  End With
  For i = 0 To UBound(ArrState)
    lRowTgt = lRowTgt + 1
    StrState = ArrState(i)
    If SheetExists(StrState) = True Then
      Call ImportSheet(StrState)
      .Worksheets(StrState).Delete
    End If
  Next
End With
Set xlWkSht = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub ImportSheet(StrSrc As String)
With ActiveWorkbook
  With .Worksheets(StrSrc).UsedRange
    lRowSrc = .Cells.SpecialCells(xlCellTypeLastCell).Row
    lColSrc = .Cells.SpecialCells(xlCellTypeLastCell).Column
    .Range("A2", .Cells(lRowSrc, lColSrc)).Copy
  End With
  With .Worksheets("Combined")
    lRowTgt = .UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
    .Paste Destination:=.Cells(lRowTgt, 1)
  End With
End With
End Sub
Function SheetExists(SheetName As String) As Boolean
' returns TRUE if the sheet exists in the active workbook
SheetExists = False
On Error GoTo NoSuchSheet
If Len(Sheets(SheetName).Name) > 0 Then
  SheetExists = True
  Exit Function
End If
NoSuchSheet:
End Function
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote