[حل شده] تقسیم بندی در اکسل

[farideh_gh]

سلام من یه فایل اکسل دارم می خوام به تعدادی که خودم می خوام مثلا 20 تا 20 تا فایلمو تقسیم کنه و یک یا چند فاصله بین هر کدوم بذاره ممنون میشم اگه کمکم کنید

[amir_ts]

با سلام
منظور شما از تقسیم فایل چیه؟آیا شیت ها رو 20 تا 20 تا میخواهید جدا کنید؟ اگر فایل نمونه قرار بدید به سرعت پاسخ گویی کمک کردید.

[farideh_gh]

نه می خوام فایل یک مانند فایل دو تقسیم بشه
ولی من بتونم هر دفعه بگم به چه تعداد تقسیم بشه که نخوام دستی تقسیم کنم

[amir_ts]

موضوع شما باید به انجمن مربوطه منتقل بشه.
از این کد استفاده کنید.

[LEFT]Sub Insert_Row()
Dim my As Integer, ur As Integer
On Error GoTo Getout
ur = InputBox("å ÊÚÏÇÏ ÑÏíÝ ãÇíá Èå ÇÖÇÝå ˜ÑÏä åÓÊíÏ")
my = InputBox("å ÊÚÏÇÏ ÑÏíÝ Èíä ÝæÇÕá ÞÑÇÏ ÏÇÔÊå ÈÇÔÏ")
Application.ScreenUpdating = False
If my = 0 Or ur = 0 Then Exit Sub
On Error GoTo Getout
Range("A" & 2 + my).Select
Do While ActiveCell.Value <> ""
5 Range(ActiveCell, ActiveCell.Offset(ur - 1, 0)).EntireRow.Insert
ActiveCell.Offset(1 + my + ur - 1, 0).Select
Loop
Getout:
Application.ScreenUpdating = True
End Sub[/LEFT]

[farideh_gh]

خیلی ممنونم فقط من اگه بخوام اینو روی فایلهای دیگه هم اعمال کنم باید چیکار کنم

[farideh_gh]

ببخشید میشه در مورد متغیرهای my و ur بیشتر توضیح بدید آخه پیغاماش ناخواناست متوجه نمیشم ممنون

[amir_ts]

خیلی ممنونم فقط من اگه بخوام اینو روی فایلهای دیگه هم اعمال کنم باید چیکار کنم

خیلی ممنونم فقط من اگه بخوام اینو روی فایلهای دیگه هم اعمال کنم باید چیکار کنم

با عرض پوزش من یادم رفته بود یک دکمه برای اجرای ماکرو بزارم. فایل تصحیح شده رو مجددا پیوست کردم.
در مورد سوالاتون تنظیمات زبان فارسی رو باید برای ویندوزتون اعمال کنید که متن فارسی قابل خواندن بشه موضوعش تو انجمن فراون هست با ی سرچ پیدا میشه کرد.
البته من تو فایل ارسالی دقیق نوشتم دو متغیری که اشاره کردید چی هستند.

برای اعمال به فایل های دیگه کد ارسالی رو باید درفایل مربوطه با زدن کلید alt+f11 و ورود به قسمت کد نویسی کپی کنید.
بعد از قسمت developer یک button (دکمه) قرار میدید و به ماکرو مربوطه وصل میکنید.

اگر سوالی بود بفرمایید.

[farideh_gh]

واقعا ازتون ممنونم بسیار عالی بود فقط یه سوال دیگه
اگه بخوام هر 20 تا رو توی یه شیت جدا بذارم باید چیکار کنم

[amir_ts]

واقعا ازتون ممنونم بسیار عالی بود فقط یه سوال دیگه
اگه بخوام هر 20 تا رو توی یه شیت جدا بذارم باید چیکار کنم

با سلام
خواهش میکنم

برای جلوگیری از به هم ریختگی و نامگذاری صحیح ، شیت اصلی رو تغیر نام بدید به master و از کد زیر استفاده کنید.
اگر هر نام دیگه ای رو برای شیت اصلی تون انتخاب کردید در کد ها هم نام شیت رو تغیر بدید.

[LEFT][COLOR=#000000]
Sub test()
Dim lastRow As Long, myRow As Long, ur As Integer, mySheet As Worksheet
lastRow = ThisWorkbook.Sheets("master").Cells(Rows.Count, 1).End(xlUp).Row
ur = InputBox("å ÊÚÏÇÏ ÑÏíÝ ãÇíá Èå ÌÏÇ ˜ÑÏä åÓÊíÏ")
For myRow = 2 To lastRow Step ur
    Set mySheet = Worksheets.Add
    Sheets("master").Rows(myRow & ":" & myRow + ur - 1).EntireRow.Copy mySheet.Range("A1")
Next myRow
End Sub



[/COLOR][/LEFT]

[farideh_gh]

بسیار ممنون و سپاسگذارم

[farideh_gh]

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

[amir_ts]

با سلام
نه بحث جداسازی تو فایل های دیگه فرق میکنه این کدها داخل workbook اضافه میکنند. اگه بخواهید داخل فایل های دیگه قرار بدید بایم کد ها رو تغیر بدیم.
میتونید از این کد ها استفاده کنید و فایل بدست امده رو تفکیک کنید تو انجمن بحث زیاد شده در این مورد.
جدا کردن شیت های فایل به صورت فایل های مجزای اکسل

برای جداسازی ردیف و انتقال به فایل دیگه هم سر فرصت روش کار میکنم.

[amir_ts]

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

با سلام
از این کد میتونید استفاده کنید.
کد اول همون کد قبلی ارسالی هست که با ترکیب یک کد دیگه شیت های جدا شده رو با گرفتن آدرس از کاربر در مسیر داده شده جدا میکند.
فقط چون ردیف های فایل حدود 800 تا هست اگر ردیف ها رو مثلا 20 تایی انتخاب کنید چند ثانیه پردازش زمان میبره.

[LEFT]
Sub Splitbook()
Dim lastRow As Long, myRow As Long, ur As Integer, mySheet As Worksheet
Dim xPath As String
Dim xws As Worksheet
lastRow = ThisWorkbook.Sheets("master").Cells(Rows.Count, 1).End(xlUp).Row
ur = InputBox("å ÊÚÏÇÏ ÑÏíÝ ãÇíá Èå ÌÏÇ ˜ÑÏä åÓÊíÏ")

          For myRow = 2 To lastRow Step ur
          Set mySheet = Worksheets.Add
          Sheets("master").Rows(myRow & ":" & myRow + ur - 1).EntireRow.Copy mySheet.Range("A1")
           Next myRow
           
         xPath = InputBox("áØÝÇ ãÓíÑ ÇíÌÇÏ ÝÇíá åÇí ÊÝ˜í˜ ÔÏå ÑÇ ãÔÎÕ ˜äíÏ", "ÂÏÑÓ ÝÇíá åí Êݘí˜í ", "D:\split")
         If xPath = "" Then GoTo 0
         If Len(Dir(xPath, vbDirectory)) = 0 Then
             MkDir xPath
         End If

       For Each xws In ThisWorkbook.Sheets
       xws.Copy
        Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xws.Name & ".xls"
        Application.ActiveWorkbook.Close False
        Next
0
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True

        End Sub
[/LEFT]