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