با سلام و احترام
من سوالی داشتم که اون رو در فایل ضمیمه گذاشتم ممنون میشم اگه جواب بدین
من سوالی داشتم که اون رو در فایل ضمیمه گذاشتم ممنون میشم اگه جواب بدین
-
-
سلام
تست کنید لطفا!
بدون vb پیشنهاد می شود
با VB دوستان شما را همراهی خواهند کرد
H3=
کد:=IFERROR(INDEX(A$3:A$15,AGGREGATE(15,6,ROW($1:$15)/($A$3:$A$16<>""),ROW(A1))),"")
Last edited by saed.rasa; 2021/07/13, 16:34.[FONT=arial][SIZE=3]اگر کسی به شما کمک کرد، سمت راست پایین هر موضوع تیک [COLOR=#0000cd][B]«3پاس»[/B][/COLOR] یادتان نرود لطفا
اگر مشکل تان حل شد، حتما تیک سبز رنگ [B][COLOR=#00cc00]«حل شد»[/COLOR][/B] در پست اول را بزنید
[/SIZE][/FONT][SIZE=3][CENTER][FONT=arial]
[/FONT][/CENTER]
[/SIZE][FONT=arial][SIZE=3] اگر میخواهید بهتر و دقیق تر و سریع تر به شما کمک شود، یک [COLOR=#ee82ee][B]«فایل نمونه»[/B][/COLOR] قرار دهید
فایل نمونه: حداکثر [U][COLOR=#ff0000]50 [/COLOR][/U]کیلوبایت - کوتاه، تقریبا [U][COLOR=#ff0000]10 [/COLOR][/U]سطری - به همراه جواب یا خروجی یا نتیجه مورد انتظار[/SIZE][/FONT][CENTER][FONT=arial][COLOR=#0000ff][SIZE=3][SIZE=3][SIZE=3][SIZE=3]مسیر ارسال فایل : پایین سمت چپ - تنظیمات اضافی - فایل پیوست[/SIZE][/SIZE][/SIZE] [/SIZE][/COLOR]
[/FONT][/CENTER] -
با سلام
این کد را امتحان کنید
کد PHP:Sub CopyData()
Dim lr As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
Range("A1:F1").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A2:F" & lr).Select
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.Copy
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
End Sub
[CENTER]
[SIGPIC][/SIGPIC]
[/CENTER]کامنت
-
با سلام .ضمن تشکراز شما می خواستم بدونم آیا امکان داره که پس از اجرای ماکرو، عملیات انجام گردیده در همان جدول ِ سمت راست باشد و جدول جدیدی ایجاد نگردد به عبارت دیگر من فقط یک جدول نیاز دارم (جدول سمت راست) و ایجاد جدول دوم کار من را سخت می کند. ممنونکامنت
-
با سلام
این کد را امتحان کنید
کد PHP:Sub CopyData()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim lr, lr2 As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
lr2 = WorksheetFunction.Count(Range("A2:A" & lr)) + 3
Range("A2:F" & lr).Select
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.Copy
Range("wwz1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("wwz1").CurrentRegion.Select
Selection.Copy
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A" & lr2 & ":F650000").Clear
Range("A1").Select
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
End Sub
[CENTER]
[SIGPIC][/SIGPIC]
[/CENTER]کامنت
-
با سلام خدمت مهندس عزیز. مشکل حل شده و یک موضوع باقی مانده و اون اینکه (در متن سوالم هم تقاضا کرده بودم) نباید سطر ها دیلت شوند و بایستی سطرها یی که داده دارند به بالا منتقل شوند و سطرهای خالی بین اونها در پایین بمونند. باز هم از وقتی که می گذارید تشکر می کنم.کامنت
-
با سلام
سطرهای آخری کد مربوط به پاک کردن داده ها را حذف میکنیم
کد PHP:Sub CopyData()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim lr, lr2 As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
lr2 = WorksheetFunction.Count(Range("A2:A" & lr)) + 3
Range("A2:F" & lr).Select
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.Copy
Range("wwz1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:F").Select
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.ClearContents
Range("wwz1").CurrentRegion.Select
Selection.Copy
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
End Sub
Last edited by generalsamad; 2021/07/15, 09:06.[CENTER]
[SIGPIC][/SIGPIC]
[/CENTER]کامنت
-
با سلام
این هم یک کد دیگه
کد PHP:Sub CopyData()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Dim lr, lr2, i As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
lr2 = WorksheetFunction.Count(Range("A2:A" & lr)) + 3
For i = 1 To lr2
If ActiveCell.Row = 1 Then
Exit For
Else
Range("A65536").End(xlUp).Select
If (ActiveCell.Offset(-1, 0) = "") Then
If ActiveCell.Row = 1 Then Exit For
ActiveCell.Offset(0, 0).Resize(1, 6).Cut ActiveCell.Offset(-1, 0)
Else
Selection.End(xlUp).Select
If ActiveCell.Row = 1 Then Exit For
ActiveCell.CurrentRegion.Cut
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
End If
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
End Sub
[CENTER]
[SIGPIC][/SIGPIC]
[/CENTER]کامنت
-
با سلام. متشکرمکامنت
کامنت