The original code worked very well for a "full table" data, but for random data the code did not work, chopping few lines off.
or Cells.SpecialCells(xlCellTypeLastCell).Address
Public ext, TabNametxt, ShtPswrd As String,
newBk As Integer
Public Sub AppenderNew()
Dim MyPath, FilesInPath, MyFiles(), lAddr As
String
Dim SourceRcount, rnum, Fnum, CalcMode,
TabNameNum As Long
Dim mybook, Appender As Workbook, BaseWks,
TabNameWS As Worksheet
Dim sourceRange As Range, destrange As Range
Dim TabName As Variant
Dim fldr As FileDialog
Dim answer As Integer
SelectExt.Show
If ext = "" Then
Exit Sub
Else
Set Appender =
ActiveWorkbook
Set fldr =
Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a folder where all files to be appended stored"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1)
End With
NextCode:
getfolder = MyPath
Set fldr = Nothing
If MyPath =
"" Then
Exit
Sub
End If
If Right(MyPath,
1) <> "\" Then
MyPath = MyPath & "\"
End If
FilesInPath =
Dir(MyPath & ext)
If FilesInPath =
"" Then
MsgBox "No files found"
Exit
Sub
End If
Fnum = 0
Do While
FilesInPath <> ""
Fnum
= Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
If
newBk = 1 Then
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 'Add a
new workbook with one sheet
Else
ActiveWorkbook.Sheets.Add After:=Sheets(1)
Set BaseWks = Sheets(2)
End
If
rnum = 1
Set TabName =
Nothing
If Fnum > 0
Then
For
Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
If TabNametxt <> ""
Then
TabName = TabNametxt
Else
TabName = 1
End If
With mybook
For Each Worksheet In
Worksheets
Worksheet.Unprotect Password:=ShtPswrd
Next
End With
With mybook.Sheets(TabName)
lAddr =
Range("A1").SpecialCells(xlCellTypeLastCell).Address
Set sourceRange =
.Range("A1:" & lAddr)
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange =
Nothing
Else
If
sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set
sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount =
sourceRange.Rows.Count
If rnum +
SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
With sourceRange
BaseWks.Cells(rnum,
"A").Resize(.Rows.Count).Value = MyFiles(Fnum)
BaseWks.Cells(rnum,
"B").Resize(.Rows.Count).Value = TabName
End With
Set destrange = BaseWks.Range("c" & rnum)
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End
If
End If
mybook.Close savechanges:=False
End If
Next
Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
With Application
.ScreenUpdating =
True
.EnableEvents =
True
.Calculation =
CalcMode
End With
End If
End Sub
Option Explicit
Private Sub newBook_Click()
newBk = 1
End Sub
Private Sub UserForm_Activate()
Me.txtTabName = ""
Me.txtShtPswrd.Text = ""
TabNametxt = Me.txtTabName.Text
ShtPswrd = Me.txtShtPswrd.Text
End Sub
Private Sub csv_Click()
ext = "*.csv"
End Sub
Private Sub Go_Click()
Unload Me
End Sub
Private Sub xls_Click()
ext = "*.xls"
End Sub
Private Sub Quit_Click()
ext = ""
Unload Me
End Sub
Private Sub txtTabName_AfterUpdate()
TabNametxt = Me.txtTabName.Text
End Sub
Private Sub txtShtPswrd_Change()
ShtPswrd = Me.txtShtPswrd.Text
End Sub
Private Sub xlsm_Click()
ext = "*.xlsm"
End Sub
Private Sub xlsx_Click()
ext = "*.xlsx"
End Sub
If you wish to say thank you please donate to the charity I use to work for.
Donate here
Comments
Post a Comment