Advanced Search

'Append data from multiple worksheet to single worksheet macro

/ Published in: Visual Basic
Save to your folder(s)
'Append data from multiple worksheet to single worksheet macro

Expand | Embed | Plain Text

Copy this code and paste it in your HTML 
  1. 'Append data from multiple worksheet to single worksheet macro
  2. Sub CombineData()
  3.  
  4.     Dim wksFirst As Worksheet
  5.     Dim wksLast As Worksheet
  6.     Dim wksDest As Worksheet
  7.     Dim strFirstSht As String
  8.     Dim strLastSht As String
  9.     Dim strDestSht As String
  10.     Dim NextRow As Long
  11.     Dim i As Long
  12.  
  13.     strFirstSht = "Sheet1" 'change the name of the first sheet accordingly
  14.     strLastSht = "Sheet2" 'change the name of the last sheet accordingly
  15.     strDestSht = "Combined Data" 'change the name of the destination sheet accordingly
  16.  
  17.     On Error Resume Next
  18.     Set wksFirst = Worksheets(strFirstSht)
  19.     If wksFirst Is Nothing Then
  20.         MsgBox strFirstSht & " does not exist...", vbInformation
  21.         Exit Sub
  22.     Else
  23.         Set wksLast = Worksheets(strLastSht)
  24.         If wksLast Is Nothing Then
  25.             MsgBox strLastSht & " does not exist...", vbInformation
  26.             Exit Sub
  27.         End If
  28.     End If
  29.     On Error GoTo 0
  30.  
  31.     Application.ScreenUpdating = False
  32.  
  33.     On Error Resume Next
  34.     Application.DisplayAlerts = False
  35.     Worksheets(strDestSht).Delete
  36.     Application.DisplayAlerts = True
  37.     On Error GoTo 0
  38.  
  39.     Set wksDest = Worksheets.add(Worksheets(1))
  40.  
  41.     wksDest.Name = strDestSht
  42.  
  43.     For i = wksFirst.Index To wksLast.Index
  44.         Worksheets(i).Range("A1:H89").Copy
  45.         With wksDest
  46.             NextRow = .Cells(.Rows.count, "A").End(xlUp).row + 1
  47.             With .Cells(NextRow, "A")
  48.                 .PasteSpecial Paste:=8 'column width for Excel 2000 and later
  49.                 .PasteSpecial Paste:=xlPasteValues
  50.                 .PasteSpecial Paste:=xlPasteFormats
  51.             End With
  52.         End With
  53.     Next i
  54.  
  55.     wksDest.Cells(1).Select
  56.  
  57.     Application.CutCopyMode = False
  58.  
  59.     Application.ScreenUpdating = True
  60.  
  61. End Sub

Report this snippet


Comments

RSS Icon Subscribe to comments

You need to login to post a comment.