How to automate copying a specific range of cells from 30 sheets into 1 sheet.

0
votes

I have 30 sheets for each day of the month. In each of them there are same columns with different data, say in the range A1:A30. So my task is to copy this range from all the sheets and past in one master sheet in different adjacent columns, ex. A1:A30, B1:B30, C1:C30 an so on.

2
excelvba
Ctrl + C and then Ctrl + V – Luuklag
@Luuklag that's not what I would call automate. – Pᴇʜ
@Nurzhan Welcome to Stack Overflow. Please notice, that this is not a free coding service. Therefore please show the code you already have and tell us where you got stuck and if you got any error messages. There are many tutorials out there (1) how to copy from one sheet to another and (2) how to find the last used column which give you a decent idea how to start your own code. – Pᴇʜ
What code have you tried? – Jeremy
Please read: Why is “Can someone help me?” not an actual question? – danieltakeshi

2 Answers

1
votes

Download and install this AddIn.

https://www.rondebruin.nl/win/addins/rdbmerge.htm

That will do the work for you, as well as many other variations of what you are doing.

enter image description here

0
votes

This is a general code for copying ranges:

Sub Copy_ranges()

   Dim NS As Worksheet

   Application.ScreenUpdating = False
   Application.EnableEvents = False

   Set NS = Sheets.Add

   i = 1
   refRange = "A1:D10"

   For Each sht In Worksheets
      If (sht.Name <> NS.Name) Then
         Set SheetRange = sht.Range(Right(refRange, Len(refRange) - InStr(refRange, "!")))
         SheetRange.Copy
         NS.Cells(i, 1).Value = sht.Name
         NS.Cells(i, 2).PasteSpecial xlPasteValues
         i = i + SheetRange.Rows.Count
      End If
   Next sht
   Application.ScreenUpdating = True
   Application.EnableEvents = True

End Sub

You may modify refRange to your range and the paste cycle to suit your needs:

Sub Copy_ranges()

    Dim NS As Worksheet

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Set NS = Sheets.Add

    i = 1
    refRange = "A1:A10"

    For Each sht In Worksheets
        If (sht.Name <> NS.Name) Then
          Set SheetRange = sht.Range(Right(refRange, Len(refRange) - InStr(refRange, "!")))
          SheetRange.Copy
          NS.Cells(1, i).Value = sht.Name
          NS.Cells(2, i).PasteSpecial xlPasteValues
          i = i + SheetRange.Columns.Count
        End If
    Next sht

    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub