با سلام.
چون وقت نبود ، حتما صحت عمل کدها رو چک کنید و اگر درست عمل کرد اعلام کنید ...
کد PHP:
On Error Resume Next
ActiveSheet.Range("a3:f1000000").Clear
Application.ScreenUpdating = False
Dim addrs As String
Dim Resu As Integer
Resu = ActiveSheet.Index
DoEvents
For i = 1 To Sheets.Count
If i <> Resu Then
Sheets(i).Range(Sheets(i).Range("a3"), Sheets(i).Range("a2").End(xlDown).Offset(0, 4).Address).Copy
ActiveSheet.Range("a1000000").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
ActiveSheet.Range("a1000000").End(xlUp).Offset(0, 5) = " اطلاعات مربوط به شیت " & Sheets(i).Name
End If
Next i
ActiveSheet.Range("a1000000").End(xlUp).Offset(1, 2).Value = Application.WorksheetFunction.Sum(Range("c3" & ":" & ActiveSheet.Range("a1000000").End(xlUp).Offset(0, 2).Address))
ActiveSheet.Range("a1000000").End(xlUp).Offset(1, 3).Value = Application.WorksheetFunction.Sum(Range("d3" & ":" & ActiveSheet.Range("a1000000").End(xlUp).Offset(0, 3).Address))
Application.ScreenUpdating = True
Application.CutCopyMode = False
علاقه مندی ها (Bookmarks)