[حل شده] انتقال فایل

[rayeagni]

سلام دوستان
کد زیر محتوای شیت یک، یک فایل اکسل رو به یک اکسل دیگه انتقال میده. چطوری این کد رو میشه تغییر داد تا همه شیتها رو به فایل مقصد انتقال بده؟ با تشکر

dim filetoopen as variant
dim openbook as workbook
application.screenupdating = false
filetoopen = application.getopenfilename(title:="browse for your file & import range", filefilter:="excel , *.xlsx; *.xlsm; *.xlsa; *.xls")
if filetoopen <> false then
set openbook = application.workbooks.open(filetoopen)
openbook.sheets(1).range("a1:a50").copy
thisworkbook.worksheets("selectfile").range("a1"). pastespecial xlpastevalues
openbook.close false

end if
application.screenupdating = true

[M_ExceL]

سلام دوستان
کد زیر محتوای شیت یک، یک فایل اکسل رو به یک اکسل دیگه انتقال میده. چطوری این کد رو میشه تغییر داد تا همه شیتها رو به فایل مقصد انتقال بده؟ با تشکر

سلام،
چک کنید :

Sub test()
Dim filetoopen As Variant
Dim openbook As Workbook
Dim lstr, i As Long
Application.ScreenUpdating = False
filetoopen = Application.GetOpenFilename(Title:="browse for your file & import range", filefilter:="excel , *.xlsx; *.xlsm; *.xlsa; *.xls")
If filetoopen <> False Then
Set openbook = Application.Workbooks.Open(filetoopen)
For i = 1 To openbook.Sheets.Count
openbook.Sheets(i).Range("a1:a50").Copy
lstr = ThisWorkbook.Worksheets("selectfile").Range("a" & Rows.Count).End(3).Row + 1
ThisWorkbook.Worksheets("selectfile").Range("a" & lstr).PasteSpecial xlPasteValues
Next
openbook.Close False
End If
Application.ScreenUpdating = True
End Sub

[rayeagni]

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

[M_ExceL]

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

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

[rayeagni]

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

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

Sheet1.Select
Dim wkbCrntWorkBook As Workbook
Dim wkbSourceBook As Workbook
Dim rngSourceRange As Range
Dim rngDestination As Range
Set wkbCrntWorkBook = ActiveWorkbook
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel ", "*.xlsx; *.xlsm; *.xlsa; *.xls"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
Workbooks.Open .SelectedItems(1)
Set wkbSourceBook = ActiveWorkbook
Set rngSourceRange = Application.Range("A:J")
wkbCrntWorkBook.Activate
Set rngDestination = Application.Range("A1")
rngSourceRange.Copy rngDestination
rngDestination.CurrentRegion.EntireColumn.AutoFit
wkbSourceBook.Close False
End If
End With

[M_ExceL]

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

Sheet1.Select
Dim wkbCrntWorkBook As Workbook
Dim wkbSourceBook As Workbook
Dim rngSourceRange As Range
Dim rngDestination As Range
Set wkbCrntWorkBook = ActiveWorkbook
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Excel ", "*.xlsx; *.xlsm; *.xlsa; *.xls"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
Workbooks.Open .SelectedItems(1)
Set wkbSourceBook = ActiveWorkbook
Set rngSourceRange = Application.Range("A:J")
wkbCrntWorkBook.Activate
Set rngDestination = Application.Range("A1")
rngSourceRange.Copy rngDestination
rngDestination.CurrentRegion.EntireColumn.AutoFit
wkbSourceBook.Close False
End If
End With

کد زیر رو امتحان کنید :

Sub test()
Dim filetoopen As Variant
Dim openbook As Workbook
Dim scunter, i, sc2, sc1 As Long

Application.ScreenUpdating = False
filetoopen = Application.GetOpenFilename(Title:="browse for your file & import range", _
filefilter:="excel , *.xlsx; *.xlsm; *.xlsa; *.xls")
    If filetoopen <> False Then
        Set openbook = Application.Workbooks.Open(filetoopen)
        sc1 = openbook.Sheets.Count
        sc2 = ThisWorkbook.Worksheets.Count
        If sc2 < sc1 Then
        scunter = 1
            Do Until scunter = sc1
                ThisWorkbook.Worksheets.Add , ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                scunter = scunter + 1
            Loop
        End If
            For i = 1 To sc1
                openbook.Sheets(i).Range("a1:a50").Copy
                ThisWorkbook.Worksheets(i).Range("a1").PasteSpecial xlPasteValues
            Next
        openbook.Close False
    End If
Application.ScreenUpdating = True

End Sub

[rayeagni]

کد زیر رو امتحان کنید :

Sub test()
Dim filetoopen As Variant
Dim openbook As Workbook
Dim scunter, i, sc2, sc1 As Long

Application.ScreenUpdating = False
filetoopen = Application.GetOpenFilename(Title:="browse for your file & import range", _
filefilter:="excel , *.xlsx; *.xlsm; *.xlsa; *.xls")
    If filetoopen <> False Then
        Set openbook = Application.Workbooks.Open(filetoopen)
        sc1 = openbook.Sheets.Count
        sc2 = ThisWorkbook.Worksheets.Count
        If sc2 < sc1 Then
        scunter = 1
            Do Until scunter = sc1
                ThisWorkbook.Worksheets.Add , ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                scunter = scunter + 1
            Loop
        End If
            For i = 1 To sc1
                openbook.Sheets(i).Range("a1:a50").Copy
                ThisWorkbook.Worksheets(i).Range("a1").PasteSpecial xlPasteValues
            Next
        openbook.Close False
    End If
Application.ScreenUpdating = True

End Sub

خیلی ممنون. تقریبا همون چیزیه که مد نظرم بود. دست شما درد نکنه ...