![]() |
#8
|
||||
|
||||
![]()
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] |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
terryg | Excel | 1 | 03-30-2015 05:18 AM |
![]() |
PeteNC | Excel | 3 | 12-07-2014 06:22 PM |
![]() |
Jhouk5244 | Office | 1 | 08-18-2011 11:06 AM |
macros to excel | evh | Excel Programming | 0 | 07-20-2011 10:12 PM |