انتقال اطلاعات از یک شیت به شیت دیگه

Collapse
این تاپیک قفل است.
X
X
Collapse
 
  • صفحه از 1
  • زمان
  • نمایش
حذف همه
new posts
قبلی template بعدی
  • ناصر خان خان

    • 2015/12/22
    • 118
    • 54.00
    #1

    [حل شده] انتقال اطلاعات از یک شیت به شیت دیگه

    سلام خدمت اساتید
    یه کد دارم که اطلاعات یک شیت و میریزه داخل شیت دیگه میخواستم بدونم میشه که همه ستونها کپی نشه هر کدوم که میخواهیم و کپی کنه.
    چون همه ستونها به دردم نمیخوره. جوری باشه که بتونم خودم هرکدوم رو که خواستم تو کد بنویسم. حتی تقدم و تاخر ستونها هم اگه بشه خیلی هم بهتر. مثلا اول b و بعد A
    درضمن تغییر نوع واندازه فونت و هم اعمال بشه.

    اینم کدی که دارم.

    متشکرم

    Sub enteqal()
    Application.ScreenUpdating = False
    For h = 1 To 22
    Sheets("database").Cells(1, h) = Sheets("data").Cells(7, h + 1)
    Next h
    lrow1 = Sheets("data").Range("b" & Rows.Count).End(xlUp).Row
    lrow2 = Sheets("database").Range("a" & Rows.Count).End(xlUp).Row
    For i = 1 To lrow1
    If Sheets("data").Range("w" & i + 7) <> "" Then
    If Sheets("data").Range("w" & i + 7) <> Sheets("database").Range("v" & i + 1) Then
    For ss = 1 To 22
    Sheets("database").Cells(i + 1, ss) = Sheets("data").Cells(i + 7, ss + 1)
    Next ss
    End If
    Else
    Exit Sub
    End If
    Next i
    Application.ScreenUpdating = True
    End Sub




    هر گاه خدا تو را به لبه پرتگاه برد باز به او اعتماد کن چون يا تو را از پشت خواهد گرفت يا پرواز را به تو خواهد آموخت
    برچسب ها: هیچ‌کدام
    • M_ExceL

      • 2018/04/23
      • 677
      #2
      نوشته اصلی توسط ناصر خان خان
      سلام خدمت اساتید
      یه کد دارم که اطلاعات یک شیت و میریزه داخل شیت دیگه میخواستم بدونم میشه که همه ستونها کپی نشه هر کدوم که میخواهیم و کپی کنه.
      چون همه ستونها به دردم نمیخوره. جوری باشه که بتونم خودم هرکدوم رو که خواستم تو کد بنویسم. حتی تقدم و تاخر ستونها هم اگه بشه خیلی هم بهتر. مثلا اول b و بعد A
      درضمن تغییر نوع واندازه فونت و هم اعمال بشه.

      اینم کدی که دارم.

      متشکرم

      Sub enteqal()
      Application.ScreenUpdating = False
      For h = 1 To 22
      Sheets("database").Cells(1, h) = Sheets("data").Cells(7, h + 1)
      Next h
      lrow1 = Sheets("data").Range("b" & Rows.Count).End(xlUp).Row
      lrow2 = Sheets("database").Range("a" & Rows.Count).End(xlUp).Row
      For i = 1 To lrow1
      If Sheets("data").Range("w" & i + 7) <> "" Then
      If Sheets("data").Range("w" & i + 7) <> Sheets("database").Range("v" & i + 1) Then
      For ss = 1 To 22
      Sheets("database").Cells(i + 1, ss) = Sheets("data").Cells(i + 7, ss + 1)
      Next ss
      End If
      Else
      Exit Sub
      End If
      Next i
      Application.ScreenUpdating = True
      End Sub




      سلام،
      بفرمایید :
      کد:
      Sub enteqal()
Application.ScreenUpdating = False
lrow1 = Sheets("data").Range("b" & Rows.Count).End(3).Row
lrow2 = Sheets("database").Range("a" & Rows.Count).End(3).Row
drow = WorksheetFunction.CountA(Sheets("data").Range("b1:b" & lrow1)) - 2
For ss = 1 To 22
Select Case ss
''''''''''''''''''''''''''''''''
Case 1
For i = 1 To drow
If Sheets("database").Cells(i + 1, 22) = "" Then
    With Sheets("database").Cells(i + 1, ss + 100).End(1).Offset(0, 1)
        .Font.Name = Sheets("data").Cells(i + 7, ss + 1).Font.Name
        .Font.Size = Sheets("data").Cells(i + 7, ss + 1).Font.Size
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
Sheets("database").Cells(i + 1, ss + 100).End(1).Offset(0, 1) = Sheets("data").Cells(i + 7, ss + 1)
End If
Next i
''''''''''''''''''''''''''''''''
Case 2
For i = 1 To drow
If Sheets("database").Cells(i + 1, 22) = "" Then
    With Sheets("database").Cells(i + 1, ss + 100).End(1).Offset(0, -1)
        .Font.Name = Sheets("data").Cells(i + 7, ss + 1).Font.Name
        .Font.Size = Sheets("data").Cells(i + 7, ss + 1).Font.Size
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
Sheets("database").Cells(i + 1, ss + 100).End(1).Offset(0, -1) = Sheets("data").Cells(i + 7, ss + 1)
End If
Next i
''''''''''''''''''''''''''''''''
'Required columns :
Case 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 14, 16, 17, 18, 19, 20, 21, 22
For i = 1 To drow
If Sheets("database").Cells(i + 1, 22) = "" Then
    With Sheets("database").Cells(i + 1, ss + 100).End(1).Offset(0, 1)
        .Font.Name = Sheets("data").Cells(i + 7, ss + 1).Font.Name
        .Font.Size = Sheets("data").Cells(i + 7, ss + 1).Font.Size
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
Sheets("database").Cells(i + 1, ss + 100).End(1).Offset(0, 1) = Sheets("data").Cells(i + 7, ss + 1)
End If
Next i
End Select
Next ss
Application.ScreenUpdating = True
End Sub
      زیر عبارت Required columns شماره ستون ها از 3 تا 22 وارد شده است،
      در صورت عدم نیاز به ستونی خاص شماره آن را قسمت اشاره شده حذف کنید.
      مثال :
      کد:
      Case 3, 6, 7
      یا حق.
      Last edited by M_ExceL; 2019/05/10, 01:33.
      [CENTER]Telegram Channel : [url]https://t.me/UltraOfficeSkills[/url]
      [/CENTER]

        کامنت

        • ناصر خان خان

          • 2015/12/22
          • 118
          • 54.00
          #3
          سلام به شما استاد گرامی و خسته نباشید.
          جناب M_ExceL متاسفانه کد مشکلاتی داره.
          1- تو ستون اول بجای اینکه اولی و کپی کنه دومین ستون کپی میشه. یعنی اگه ستون اول تاریخ باشه و ستون دوم مثلا قیمت باشه، اول قیمت و کپی میکنه و بعد تاریخ و.
          خوب این یکی از درخواست من همین بود(تقدم و تاخر) ولی با کنترل اما این همینطوری داره میزنه.
          2- دومین مشکل اینه که بعد از کپی اول اگه اطلاعات اضاف شد دوباره بخواهیم از اطلاعات کپی بگیریم چند تا ستون دیگه هم اضاف میکنه بدون هیچ ترتیبی
          و در آخر لطفا بگید چطوری نوع و اندازه فونتها رو تغییر بدم.

          ظاهراً کسی غیر از شما جواب نمیده؟؟؟؟!!!!!
          بنده منتظر جوابتون مثل همیشه هستم. و عذرخواهی میکنم بابت دردسری که دارم.
          متشکرم از بابت صبوری و جوابهاتون.
          Last edited by ناصر خان خان; 2019/05/10, 02:38.
          هر گاه خدا تو را به لبه پرتگاه برد باز به او اعتماد کن چون يا تو را از پشت خواهد گرفت يا پرواز را به تو خواهد آموخت

            کامنت

            • M_ExceL

              • 2018/04/23
              • 677
              #4
              نوشته اصلی توسط ناصر خان خان
              سلام به شما استاد گرامی و خسته نباشید.
              جناب M_ExceL متاسفانه کد مشکلاتی داره.
              1- تو ستون اول بجای اینکه اولی و کپی کنه دومین ستون کپی میشه. یعنی اگه ستون اول تاریخ باشه و ستون دوم مثلا قیمت باشه، اول قیمت و کپی میکنه و بعد تاریخ و.
              خوب این یکی از درخواست من همین بود(تقدم و تاخر) ولی با کنترل اما این همینطوری داره میزنه.
              2- دومین مشکل اینه که بعد از کپی اول اگه اطلاعات اضاف شد دوباره بخواهیم از اطلاعات کپی بگیریم چند تا ستون دیگه هم اضاف میکنه بدون هیچ ترتیبی
              و در آخر لطفا بگید چطوری نوع و اندازه فونتها رو تغییر بدم.

              ظاهراً کسی غیر از شما جواب نمیده؟؟؟؟!!!!!
              بنده منتظر جوابتون مثل همیشه هستم. و عذرخواهی میکنم بابت دردسری که دارم.
              متشکرم از بابت صبوری و جوابهاتون.
              سلام،
              کد زیر رو تست کنید :
              کد:
              Sub enteqal()
Application.ScreenUpdating = False
lrow1 = Sheets("data").Range("b" & Rows.Count).End(3).Row
lrow2 = Sheets("database").Range("a" & Rows.Count).End(3).Row
drow = WorksheetFunction.CountA(Sheets("data").Range("b1:b" & lrow1)) - 2
For ss = 1 To 22
Select Case ss
'Required columns :
Case 1, 2, 3, 4, 5, 6, 7, 8, 9, 15, 20, 22
lcol = 12
If Sheets("database").Cells(2, lcol) = "" Then
For i = 1 To drow
    With Sheets("database").Cells(i + 1, ss + 100).End(1).Offset(0, 1)
        .Font.Name = Sheets("data").Cells(i + 7, ss + 1).Font.Name
        .Font.Size = Sheets("data").Cells(i + 7, ss + 1).Font.Size
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Value = Sheets("data").Cells(i + 7, ss + 1)
    End With
        If Sheets("database").Cells(i + 1, 2) <> "" Then
        Sheets("database").Cells(i + 1, 1) = i
        End If
Next i
End If
End Select
Next ss
Application.ScreenUpdating = True
End Sub
              زیر عبارت Required columns و مقابل Case شماره ستون های مورد نیاز رو وارد کنید.
              همچنین بعد از وارد کردن شماره ستون ها، تعداد ستون ها را شمارش کرده و تعداد آن را مقابل lcol وارد کنید.
              در خصوص نوع و اندازه فونت هم، فونت و اندازه ستون های شیت اول در شیت دوم اعمال میشه.
              در خصوص «تقدم و تاخر» هم که فرمودید میشه مانند کد قبلی داخل کد تعریف کرد که بطور مثال اول ستون 2 بعد ستون مثلا 1 رو منتقل کند.
              [CENTER]Telegram Channel : [url]https://t.me/UltraOfficeSkills[/url]
              [/CENTER]

                کامنت

                • ناصر خان خان

                  • 2015/12/22
                  • 118
                  • 54.00
                  #5
                  با سلام وتشکر
                  باز هم نشد استاد گرامی این بار برای بار دوم دیکه کپی نمیکنه یعنی اگه اطلاعات اضافه شد دیگه اون اضافه شده ها رو اعمال نمیکنه و همینطور تقدم وتاخر و اعمال نمیکنه.
                  بغیر این دو مورد دیگه مشکلی نیست.

                  متشکرم
                  هر گاه خدا تو را به لبه پرتگاه برد باز به او اعتماد کن چون يا تو را از پشت خواهد گرفت يا پرواز را به تو خواهد آموخت

                    کامنت

                    • M_ExceL

                      • 2018/04/23
                      • 677
                      #6
                      نوشته اصلی توسط ناصر خان خان
                      با سلام وتشکر
                      باز هم نشد استاد گرامی این بار برای بار دوم دیکه کپی نمیکنه یعنی اگه اطلاعات اضافه شد دیگه اون اضافه شده ها رو اعمال نمیکنه و همینطور تقدم وتاخر و اعمال نمیکنه.
                      بغیر این دو مورد دیگه مشکلی نیست.

                      متشکرم
                      سلام،
                      کد اصلاح گردید :
                      کد:
                      Sub enteqal()
Application.ScreenUpdating = False
lrow1 = Sheets("data").Range("b" & Rows.Count).End(3).Row
lrow2 = Sheets("database").Range("a" & Rows.Count).End(3).Row
drow = WorksheetFunction.CountA(Sheets("data").Range("b1:b" & lrow1)) - 2
For ss = 1 To 22
Select Case ss
'Required columns :
Case 1, 2, 3, 4, 5, 6, 7, 8, 9, 15, 20, 22
lcol = 12
For i = 1 To drow
If Sheets("database").Cells(i + 1, lcol) = "" Then
    With Sheets("database").Cells(i + 1, ss + 100).End(1).Offset(0, 1)
        .Font.Name = Sheets("data").Cells(i + 7, ss + 1).Font.Name
        .Font.Size = Sheets("data").Cells(i + 7, ss + 1).Font.Size
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Value = Sheets("data").Cells(i + 7, ss + 1)
    End With
        If Sheets("database").Cells(i + 1, 2) <> "" Then
        Sheets("database").Cells(i + 1, 1) = i
        End If
End If
Next i
End Select
Next ss
Application.ScreenUpdating = True
End Sub
                      مواردی که در پست قبل گفتم انجام بدید سپس کد رو اجرا کنید
                      در اولین اجرا ابتدا تمام اطلاعات شیت دوم رو پاک کنید.
                      در خصوص «تقدم و تاخر» ترتیب ستون هاتون رو بگید تا کد رو اصلاح کنم.
                      یا حق.
                      [CENTER]Telegram Channel : [url]https://t.me/UltraOfficeSkills[/url]
                      [/CENTER]

                        کامنت

                        • ناصر خان خان

                          • 2015/12/22
                          • 118
                          • 54.00
                          #7
                          با تشکر از شما و اینکه پیگیرمشکل بنده هستید و جواب میدهید.
                          بنده دفعه اول فایل و ارسال کردم نمیدانم چرا دیگر نمیشود یا بنده ایتم مربوط به ارسال فایل و نمیبینم.
                          تو فایل بنده 23 ستون است که، ستون آخری باید اول بیاید. و یک ستون خالی هم اول داریم که جزء جدول نیست یعنی A کلا خالی است. پس ستون 23 که W است باید هنگان کپی بیاد اول. همین.
                          ولی این کد جدید دوباره یه مشکلی پیدا کرده. زمان کپی اول درست کپی میشود ولی در انتقال های بعدی، در آخر، چند ستون دیگر اضافه میکند. مثلا تاریخ و قیمت مجددا تکرار میشود.
                          همین.
                          بابت این کد خیلی اذیت کردم. عذرخواهی میکنم
                          متشکر و ممنون
                          هر گاه خدا تو را به لبه پرتگاه برد باز به او اعتماد کن چون يا تو را از پشت خواهد گرفت يا پرواز را به تو خواهد آموخت

                            کامنت

                            • M_ExceL

                              • 2018/04/23
                              • 677
                              #8
                              نوشته اصلی توسط ناصر خان خان
                              با تشکر از شما و اینکه پیگیرمشکل بنده هستید و جواب میدهید.
                              بنده دفعه اول فایل و ارسال کردم نمیدانم چرا دیگر نمیشود یا بنده ایتم مربوط به ارسال فایل و نمیبینم.
                              تو فایل بنده 23 ستون است که، ستون آخری باید اول بیاید. و یک ستون خالی هم اول داریم که جزء جدول نیست یعنی A کلا خالی است. پس ستون 23 که W است باید هنگان کپی بیاد اول. همین.
                              ولی این کد جدید دوباره یه مشکلی پیدا کرده. زمان کپی اول درست کپی میشود ولی در انتقال های بعدی، در آخر، چند ستون دیگر اضافه میکند. مثلا تاریخ و قیمت مجددا تکرار میشود.
                              همین.
                              بابت این کد خیلی اذیت کردم. عذرخواهی میکنم
                              متشکر و ممنون
                              خواهش میکنم چه اذیتی،
                              جهت ارسال فایل، تنظیمات اضافی رو بزنید سپس فایلتون رو اپلود کنید
                              بنده سر فرصت این کد رو اصلاح میکنم و اگر نشد کد بهتری رو اماده خواهم کرد.
                              [CENTER]Telegram Channel : [url]https://t.me/UltraOfficeSkills[/url]
                              [/CENTER]

                                کامنت

                                • ناصر خان خان

                                  • 2015/12/22
                                  • 118
                                  • 54.00
                                  #9
                                  متشکرم . میخواستم فایل و کامل بفرستم تا هم یه نظر بدید و هم شاید کلا عوضش کردید. اما میخوام فایل و بطور خصوصی بفرستم ولی ظاهرا انجا ارسال فایل نداره.

                                  اگه صلاح میدونید یه راهی بگید تا کل فایل و بفرستم.
                                  اگر تقدم تاخر مشکل ایجاد میکنه بگید خوب ستونها رو توی دیتا عوض کنم. چون زمان میبره و کلی فرمول و تابع رو باید دستکاری کنم. برای همینه اینکار و تابحال نکردم.
                                  فایل های پیوست شده
                                  Last edited by ناصر خان خان; 2019/05/11, 14:18.
                                  هر گاه خدا تو را به لبه پرتگاه برد باز به او اعتماد کن چون يا تو را از پشت خواهد گرفت يا پرواز را به تو خواهد آموخت

                                    کامنت

                                    • M_ExceL

                                      • 2018/04/23
                                      • 677
                                      #10
                                      نوشته اصلی توسط ناصر خان خان
                                      متشکرم . میخواستم فایل و کامل بفرستم تا هم یه نظر بدید و هم شاید کلا عوضش کردید. اما میخوام فایل و بطور خصوصی بفرستم ولی ظاهرا انجا ارسال فایل نداره.

                                      اگه صلاح میدونید یه راهی بگید تا کل فایل و بفرستم.
                                      اگر تقدم تاخر مشکل ایجاد میکنه بگید خوب ستونها رو توی دیتا عوض کنم. چون زمان میبره و کلی فرمول و تابع رو باید دستکاری کنم. برای همینه اینکار و تابحال نکردم.
                                      سلام،
                                      بعلت فریز شدن برخی ردیف ها، کد ها خطا میداد که مجبور شدم بصورت زیر بنویسم
                                      فکر نمیکنم مشکلی باشه.
                                      کد:
                                      Sub enteqal()
Application.ScreenUpdating = False
lrow1 = Sheets("data").Range("b" & Rows.Count).End(3).Row
lrow2 = Sheets("database").Range("a" & Rows.Count).End(3).Row
drow = WorksheetFunction.CountA(Sheets("data").Range("b1:b" & lrow1)) - 2

Sheets("data").Range("b8:b" & drow + 7).Copy
Sheets("database").Range("a2:a" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("a2:a" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("w8:w" & drow + 7).Copy
Sheets("database").Range("b2:b" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("b2:b" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("c8:c" & drow + 7).Copy
Sheets("database").Range("c2:c" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("c2:c" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("d8:d" & drow + 7).Copy
Sheets("database").Range("d2:d" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("d2:d" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("e8:e" & drow + 7).Copy
Sheets("database").Range("e2:e" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("e2:e" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("f8:f" & drow + 7).Copy
Sheets("database").Range("f2:f" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("f2:f" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("g8:g" & drow + 7).Copy
Sheets("database").Range("g2:g" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("g2:g" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("k8:k" & drow + 7).Copy
Sheets("database").Range("h2:h" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("h2:h" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("l8:l" & drow + 7).Copy
Sheets("database").Range("i2:i" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("i2:i" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("n8:n" & drow + 7).Copy
Sheets("database").Range("j2:j" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("j2:j" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("o8:o" & drow + 7).Copy
Sheets("database").Range("k2:k" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("k2:k" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("p8:p" & drow + 7).Copy
Sheets("database").Range("l2:l" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("l2:l" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("q8:q" & drow + 7).Copy
Sheets("database").Range("m2:m" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("m2:m" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("r8:r" & drow + 7).Copy
Sheets("database").Range("n2:n" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("n2:n" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("s8:s" & drow + 7).Copy
Sheets("database").Range("o2:o" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("o2:o" & drow + 1).PasteSpecial (xlPasteFormats)

Sheets("data").Range("t8:t" & drow + 7).Copy
Sheets("database").Range("p2:p" & drow + 1).PasteSpecial (xlPasteValues)
Sheets("database").Range("p2:p" & drow + 1).PasteSpecial (xlPasteFormats)

Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
                                      [CENTER]Telegram Channel : [url]https://t.me/UltraOfficeSkills[/url]
                                      [/CENTER]

                                        کامنت

                                        • ناصر خان خان

                                          • 2015/12/22
                                          • 118
                                          • 54.00
                                          #11
                                          دمت گرم خودشه بالاخره تموم شد اذیت شدی متشکرم
                                          هر گاه خدا تو را به لبه پرتگاه برد باز به او اعتماد کن چون يا تو را از پشت خواهد گرفت يا پرواز را به تو خواهد آموخت

                                            کامنت

                                            قبلی template بعدی
                                            چند لحظه..