Copy selected range from all worksheets and paste it in summary sheet

Morty

New Member
Joined
Jun 9, 2021
Messages
27
Hello all, after week of trying, I ended in miserable pit :D. So i would like to polite ask how to solve my problem. I will have many, probably 10 sheets. In this scenario i have only 2 for explaining. I would like to copy and paste values from chosen cells (picture 1: merged cells E10 : J11, E13 : J13 and range of C19:J21). The last used row in this range C19:J21 will be C30:J30 according to need of adding another codes. So i would like to copy and paste only non empty cells with values from this imaginary table. I need to put this values in specific order into summary sheet (picture 2). To explaine, sheets are designed for just put values in and print. And the first one is summary for review. And to be greedy, I would like to have 1 blank row between each Site table (via picture 2). I am sorry for this horrible explanation :D. I hope someone will find a way through this and will be able to help me :D. I thank you all in advance and wish you to have a great rest of the day.

P.S. I tried many codes, but my skills in VBA syntaxes are just null :(, I have some in R :D.

Best regards,
Morty
 

Attachments

  • 1.png
    1.png
    51.9 KB · Views: 12
  • 2.png
    2.png
    61 KB · Views: 12

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
Hi and welcome to MrExcel

I highly recommend removing merged cells and using single cells. You can have the same presentation on the sheet and fewer problems when working with cells, especially when using macros.

varios 10jun2021.xlsm
ABCDEFGH
1
2
3
4
5
6
7
8
9
10SiteName1
11
12
13Object number01-20-01
14
15
16
17CodeTypeAmount
1817 01 011100
1918 01 012200
2019 01 013300
2120 01 014400
22
23
Sheet1 (2)


But if your merged cells are necessary, then I prepare the macro to work that way.
 
Upvote 0
Hello Dante and really thank you for your reply :). Unfortunately, I need it with merged cells in this format even if I know they are good for nothing :/. It´s official companies report for our partners and must have this format. I tried to search some more solutions, but no found code is suitable for my case. I know it will have to be loop and .select . copy . offset probably .pastespecial with those merged cells and others. But i am not able to put it together :D :D, I am getting only errors :D.
 
Upvote 0
Taking the structure of your sheets according to your images.
Try the macro SummarySheet.


Put all the code in the module:
VBA Code:
Sub SummarySheet()
  Dim sh As Worksheet, sumSh As Worksheet
  Dim i As Long, lr1 As Long, lr2 As Long, n As Long
    
  Application.ScreenUpdating = False
  
  Set sumSh = Sheets("summary")
  Range("A2:K" & Rows.Count).Clear
  
  lr1 = 2
  For Each sh In Sheets
    Select Case LCase(sh.Name)
      Case LCase(sumSh.Name)
      Case Else
        lr2 = sh.Range("C" & Rows.Count).End(3).Row
        If lr2 < 18 Then lr2 = 18
        
        sh.Range("C18:J" & lr2).Copy
        sumSh.Range("D" & lr1).PasteSpecial xlPasteValues
        sumSh.Range("D" & lr1).PasteSpecial xlPasteFormats
        n = lr2 - 17
      
        Call Format_Cells(n, sumSh.Range("A" & lr1), sh.Name)
        Call Format_Cells(n, sumSh.Range("B" & lr1), sh.Range("E10").Value)
        Call Format_Cells(n, sumSh.Range("C" & lr1), sh.Range("E13").Value)
        
        lr1 = lr1 + n + 1
    End Select
  Next
End Sub

Sub Format_Cells(n As Long, xRange As Range, xValue As Variant)
  With xRange
    .Resize(n).Merge
    .Resize(n).Borders.LineStyle = xlContinuous
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Value = xValue
  End With
End Sub
 
Upvote 0
Hello, we are almost there but sadly not yet :D. I am posting 3 mini sheets: 1. is result of your macro, 2. is desired result and 3. is structure of my sheets. I really apreciate your help :) and wish you beautiful weekend.

VBA-test.xlsm
ABCDEFGHIJK
1
2sheet 1Building########
3111
4111
5111
6
7
8
9
10
11
12
13
14
15
16for the period:
17
18for company:
19
20Date:
21
22
23Sign:
24
25sheet 2Building########
26222
27222
28222
29222
30222
31
32
33
34
35
36
37
38
39for the period:
40
41for company:
42
43Date:
44
45
46Sign:
Summary
Cells with Conditional Formatting
CellConditionCell FormatStop If True
D26:K37Celldoes not contain a blank value textNO
D3:K14Celldoes not contain a blank value textNO


VBA-test.xlsm
NOPQRSTUVWX
1SheetBuildingSO / PSCodeCategoryAmount
2
3Sheet 1Building 101-20-0117 05 01O1500
417 05 02O200
517 05 03O3700
6
7Sheet 1Building 101-30-0112 04 01O30 000
812 04 02O500
912 04 03O1000
1012 04 04N1700
1112 04 05N500
Summary


VBA-test.xlsm
ABCDEFGHIJK
1
2
3
4
5
6
7
8Protocol
9
10Site: Building 1
11
12
13Object number: 01-20-01
14
15Název SO/PS:
16
17CodeTypeAmoun
18
19111
20111
21111
22
23
24
25
26
27
28
29
30
31
32for the period:
33
34for company:
35
36Date:
37
38
39Sign:
sheet 1
Cells with Conditional Formatting
CellConditionCell FormatStop If True
C19:J30Celldoes not contain a blank value textNO
 
Upvote 0
1623430154741.png


That was not in your initial image ?.

Try this:

VBA Code:
Sub SummarySheet()
  Dim sh As Worksheet, sumSh As Worksheet
  Dim i As Long, lr1 As Long, lr2 As Long, n As Long
    
  Application.ScreenUpdating = False
  
  Set sumSh = Sheets("summary")
  sumSh.Range("A2:K" & Rows.Count).Clear
  
  lr1 = 2
  For Each sh In Sheets
    Select Case LCase(sh.Name)
      Case LCase(sumSh.Name)
      Case Else
        lr2 = 18
        Do While sh.Range("C" & lr2).Value <> ""
          lr2 = lr2 + 1
        Loop
        lr2 = lr2 - 1
        If lr2 < 18 Then lr2 = 18
        
        sh.Range("C18:J" & lr2).Copy
        sumSh.Range("D" & lr1).PasteSpecial xlPasteValues
        sumSh.Range("D" & lr1).PasteSpecial xlPasteFormats
        n = lr2 - 17
      
        Call Format_Cells(n, sumSh.Range("A" & lr1), sh.Name)
        Call Format_Cells(n, sumSh.Range("B" & lr1), sh.Range("E10").Value)
        Call Format_Cells(n, sumSh.Range("C" & lr1), sh.Range("E13").Value)
        
        lr1 = lr1 + n + 1
    End Select
  Next
End Sub

Sub Format_Cells(n As Long, xRange As Range, xValue As Variant)
  With xRange
    .Resize(n).Merge
    .Resize(n).Borders.LineStyle = xlContinuous
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Value = xValue
  End With
End Sub
 
Upvote 0
Almost there, but still not yet. Its not showing values, only 1 row per every sheet. I can show you my whole workbook. First sheet is result by your macro and second 1 is desired. I think this will be the easiest way :D. Still thank you for all your effort :). Tried to find free english website for upload and share, so here it is: VBA-test :D
 
Upvote 0
Almost there
Try this

VBA Code:
Sub Summary()
  Dim sh As Worksheet, sumSh As Worksheet
  Dim i As Long, lr1 As Long, lr2 As Long, n As Long
    
  Application.ScreenUpdating = False
  
  Set sumSh = Sheets("summary Result")
  sumSh.Range("A2:K" & Rows.Count).Clear
  
  lr1 = 2
  For Each sh In Sheets
    Select Case LCase(sh.Name)
      Case LCase(sumSh.Name), LCase("Summary desired")
      Case Else
        lr2 = 19
        Do While sh.Range("C" & lr2).Value <> ""
          lr2 = lr2 + 1
        Loop
        lr2 = lr2 - 1
        If lr2 < 19 Then lr2 = 19
        
        sh.Range("C19:J" & lr2).Copy
        sumSh.Range("D" & lr1).PasteSpecial xlPasteValues
        sumSh.Range("D" & lr1).PasteSpecial xlPasteFormats
        n = lr2 - 17
      
        Call Format_Cells(n, sumSh.Range("A" & lr1), sh.Name)
        Call Format_Cells(n, sumSh.Range("B" & lr1), sh.Range("E10").Value)
        Call Format_Cells(n, sumSh.Range("C" & lr1), sh.Range("E13").Value)
        
        lr1 = lr1 + n + 1
    End Select
  Next
End Sub

Sub Format_Cells(n As Long, xRange As Range, xValue As Variant)
  With xRange
    .Resize(n).Merge
    .Resize(n).Borders.LineStyle = xlContinuous
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Value = xValue
  End With
End Sub
 
Upvote 0
Amazing :). Thank you very much. This is the result:

VBA-test2.xlsm
ABCDEFGHIJK
1List č.StavbaSO / PSKat. číslo odpaduNázev odpaduMnožství
2List 1Building 220.01.2001111
3111
4111
5
6
7List 2Building 201-40-01222
8222
9222
10222
11222
12
13
14List 3Building 322.01.2001333
15333
16333
17333
18333
19
20
21List 4Building 430.01.2001444
22444
23
Summary
Cells with Conditional Formatting
CellConditionCell FormatStop If True
D21:K22Celldoes not contain a blank value textNO
D14:K18Celldoes not contain a blank value textNO
D7:K11Celldoes not contain a blank value textNO
D2:K4Celldoes not contain a blank value textNO


I am just going to edit

sh.Range("C19:J" & lr2).Copy
sumSh.Range("D" & lr1).PasteSpecial xlPasteValues
sumSh.Range("D" & lr1).PasteSpecial xlPasteFormats
n = lr2 - 17 ( to 18, it deletes the blank added last rows )

and lr1 = lr1 + n + 1 ( to +2 to have extra space between tables )

Last question, i have problems still with the cell "E13" which is in made summary under column C. It seems that the used format for this cell X-X-X is forcing excel to change text to date. I have tried basic formating in the original cells or have tried to use " ' " before cell number or .Value = " ' " & MyValue ... But like usual nothing works :D. Once again I really thank you :)
 
Upvote 0
n = lr2 - 17 ( to 18, it deletes the blank added last rows )
I forgot that part
__________________

i have problems still with the cell "E13" It seems that the used format for this cell X-X-X is forcing excel to change text to date.

Just change this line
Call Format_Cells(n, sumSh.Range("C" & lr1), sh.Range("E13").Value)

For this:
Call Format_Cells(n, sumSh.Range("C" & lr1), "'" & sh.Range("E13").Value)
 

Attachments

  • 1623673065225.png
    1623673065225.png
    10.6 KB · Views: 5
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,205
Members
448,554
Latest member
Gleisner2

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