copy کردن اطلاعات

[exceliran]

با عرض سلام
چطوری میشه با vb در فایل ضمیمه شده کد موجود رو اصلاح کرد تا در صورتی که ستون a در شیت 1 پر شد، اطلاعات a:g اون سلول هایی که پر شدن رو به شیت 2 انتقال بده. درواقع میخایم اطلاعات a2:g12 رو از شیت 1 به شیت 2 انتقال بدیم فقط قبل از کپی شدن به شیت2 بررسی کنه اگر ستون a2:a4 پر بود فقط اون سطرهارو انتقال بده و اگر a2:a6 پر بود فقط اونارو انتقال بده.
باتشکر فراوان

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.

[Ali Parsaei]

سلام،
با توجه به اينکه خانه هايتان حاوي فرمول است چيزي که به ذهن من مي رسد اين است که با کد نويسي اول مقادير را فيلتر نموده و بعد در شيت دو کپي کنيم، ببينيد اين کد به دردتان مي خورد:

 Range("a1:g1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$G$12").AutoFilter Field:=1, Criteria1:="<>"
    Range("A2").Select
    Selection.Resize(Selection.End(xlDown).Row - Selection.Row() + 1, 7).Select
    Selection.Copy
    Sheet2.Activate
    Range("A2").Select
    ActiveSheet.Paste
    Sheet1.Activate
    Selection.AutoFilter
    Application.CutCopyMode = False

[iranweld]

با سلام و کسب اجازه مهندس پارسا
فایل پیوست را بررسی بفرمایید ببنید همین مد نظر شماست؟

[Amir Ghasemiyan]

دوستان زحمت كشيدن و دو روش گفتن. من هم يك روش ديگه اضافه ميكنم. اميدوارم مورد استفاده قرار بگيره

Sub exceliran()
Dim i As Integer
Dim w As Range
Dim ar() As Variant
i = 0
Sheet1.Select
For Each w In Range("A2:A12")
    If w.Value <> "" Then
        ReDim Preserve ar(i)
        ar(i) = Range("A" & w.Row & ":G" & w.Row)
        i = i + 1
    End If
Next w
Sheet2.Select
freerow = Range("A2").End(xlDown).Offset(1, 0).Row
For i = 0 To UBound(ar)
    Range("A" & freerow & ":G" & freerow) = ar(i)
    freerow = freerow + 1
Next i
End Sub