Hi dear friends
first of all , rename sheet1 to Summary or any name that you want then imagine that you want to copy all cells in range ("A :C") so use below code to do that. As It you can see these code was written in module, so copy that in module then connect with it with a button(from form) to run it easily
as it can be seen , first of all in the code we clear all data in sheet1( i mean summary sheet) then determine the header of columns by using array
you can change any part of the ranges or array to get your desired style.
if you have any question about this, feel free and post your question
Sincerely Yours
first of all , rename sheet1 to Summary or any name that you want then imagine that you want to copy all cells in range ("A :C") so use below code to do that. As It you can see these code was written in module, so copy that in module then connect with it with a button(from form) to run it easily
as it can be seen , first of all in the code we clear all data in sheet1( i mean summary sheet) then determine the header of columns by using array
you can change any part of the ranges or array to get your desired style.
if you have any question about this, feel free and post your question
Sincerely Yours
کد:
Sub SummurizeSheets()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Sheet1.Cells.ClearContents
Sheet1.Range("A1:C1").Value = Array("National code", "Name and family name", "Locatction")
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
With Sheet1
lastrow1 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
If ws.CodeName <> "Sheet1" And ws.Range("A2").Value <> "" Then
ws.Select
lastrow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Range("A2:C" & lastrow).Select
Selection.Copy
Sheet1.Select
Range("A" & lastrow1 + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next ws
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
کامنت