VBA to append data into columns (only tables) - excluding a random cell

omgxdee

New Member
Joined
Nov 30, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
Hi friends,

I am using Microsoft Office 365 and found a macros code to use for my project. However, I am facing some issues whereby my appended "Result" data contains random cell notes (Example: Updated xxx).
Is there any way to only append the main table data? Please note that I am not able to remove "Updated xxx" and it can be placed anywhere after the table (any column, any row).

The headers in each sheet between "Start" and "Finish" are the same (same no of columns). However, no. of rows can differ.
image1.JPG

Kindly seek your help on this issue :)
this is to append multiple sheets into a single sheet called "Results" but I have placed only 2 "SG" and "JP" for easy reference.

The code used was from: VBA - Macro to Combine (Append) Sheets - E for Excel



VBA Code:
Sub MergeSheets()
  
    Dim HasHeaderRow As String * 1, SameWorkbook As String * 1
    Dim OPSheet As String
    Dim ToDir As String, FileName As String
  
 '******** Change Parameters in this section ****************
    'Set the values for HasHeaderRow and ToDir
    HasHeaderRow = "Y"
    SameWorkbook = "Y"
    OPSheet = "Result"
  
    'Set the Save Directory and File Name if result is not wanted in the same workbook
    If SameWorkbook <> "Y" Then
        ToDir = "C:\Junk\"
        FileName = "Combined"
    End If
'***************************************************************
  
    Call Merge(HasHeaderRow = "Y", SameWorkbook = "Y", OPSheet, ToDir, FileName)

End Sub

Sub Merge(ByVal HasHeaderRow As Boolean, ByVal SameWorkbook As Boolean, ByVal OPSheet As String, _
            ByVal ToDir As String, ByVal FileName As String)
  
    Dim i As Long, StartIndex As Long
    Dim ToPath As String
    Dim TWk As Workbook, SWk As Workbook
    Dim Ws As Worksheet
    Dim Rng As Range, NewCell As Range
    Dim StartExists As Boolean, x As Boolean
  
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
  
    Set SWk = ActiveWorkbook
  
    'Check for the existence of directory if output is needed in a different directory
    If SameWorkbook = False Then
        If Right(ToDir, 1) <> "\" Then
            ToDir = ToDir & "\"
        End If
        On Error Resume Next
            If Dir(ToDir) = "" Then
                MsgBox ToDir & " does not exist"
                Exit Sub
            End If
        On Error GoTo 0
      
        'Set the file name which is FileName_Current Date_Current Time
        ToPath = ToDir & FileName & "_" & Format(Date, "mmddyy") & "_" & Format(Time, "hhmmss")
      
        'Create the workbook where data needs to be copied
        Set TWk = Workbooks.Add
        Else
        Set TWk = SWk
    End If
  
    'Create OPSheet.
    On Error Resume Next
        Set Ws = TWk.Worksheets(OPSheet)
        If Err.Number <> 0 Then
            TWk.Worksheets.Add(Before:=TWk.Worksheets(1)).Name = OPSheet
        End If
    On Error GoTo 0
    'If OPSheet is existing, just clear it
    TWk.Worksheets(OPSheet).Cells.Clear
  
    'Check for existence of Start Sheet - If Start Sheet is there
    'then combine from Start otherwise combine from 1st sheet itself
    On Error Resume Next
    With SWk
        Set Ws = .Worksheets("Start")
            If Err.Number = 0 Then
                StartExists = True
                StartIndex = .Worksheets("Start").Index + 1
                Else
                'If within the same workbook, then we need to increase the index by 1 as first sheet is Result sheet now
                If SameWorkbook = True Then
                    StartIndex = 2
                    Else
                    StartIndex = 1
                End If
            End If
        On Error GoTo 0
      
        'Set the starting cell in first sheet of Target Workbook
        Set NewCell = TWk.Worksheets(OPSheet).Range("A1")
      
        For i = StartIndex To .Worksheets.Count
            'If there is a sheet names Finish, then stop combining
            If .Worksheets(i).Name = "Finish" Then Exit For
                If .Worksheets(i).Name <> "Result" Then
                'Check if the sheet is blank or not - If blank, no need to process
                If WorksheetFunction.CountA(.Worksheets(i).Cells) - WorksheetFunction.CountA(.Worksheets(i).Rows(1)) <> 0 Then
                    'x is a parameter which is set after first processing. In first processing, Header Row is not important
                    'But starting second processing, Header Row is Important. If Header Row is Y, then we should not select
                    'first row. Hence, x is set to True in this case.
                    If x = False Then
                        Set Rng = .Worksheets(i).UsedRange
                        Else
                        Set Rng = .Worksheets(i).UsedRange.Offset(1, 0)
                        Set Rng = Rng.Resize(Rng.Rows.Count - 1)
                    End If
                    'Copy the Range to Target Workbook
                    Rng.Copy NewCell
                    'Set the new cell to Next row of Column A in Target Workbook
                    Set NewCell = TWk.Worksheets(OPSheet).Cells(TWk.Worksheets(OPSheet).UsedRange.Rows.Count + 1, "A")
                    'Set NewCell = TWk.Worksheets(OPSheet).Cells(Rng(Rng.Cells.Count).Row + 1, "A")
                    If HasHeaderRow = True Then
                        x = True
                    End If
                End If
            End If
        Next i
    End With
  
    If SameWorkbook = False Then
        TWk.SaveAs FileName:=ToPath, FileFormat:=51
    End If
  
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.CutCopyMode = False

End Sub

Thank you
 

Attachments

  • image2.JPG
    image2.JPG
    182.8 KB · Views: 18
  • image3.JPG
    image3.JPG
    250.3 KB · Views: 17
Last edited by a moderator:

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

Forum statistics

Threads
1,213,543
Messages
6,114,243
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top