Excel VBA - حلقة من خلال المجلد وإضافة أجزاء معينة من الأسماء إلى الخلايا في المصنف

1

أحاول أداء تمرين بسيط - (1) دمج عدة علامات تبويب (كل منها من ملف منفصل) في ملف واحد ("ملف ماكرو") ، (2) إعادة تسمية جميع علامات التبويب وفقًا لخلايا معينة في علامات التبويب هذه.

كل علامة تبويب هي عبارة عن كشف حساب مصرفي (بعملات مختلفة) ، لذلك تكون جميع علامات التبويب بنفس الهيكل. لقد عثرت على ماكرو (لست متخصصًا في VBA ، لذا فإن هذا يتعلق أكثر بـ "البحث والتكيف" بدلاً من "الكتابة بنفسي") لدمجها جميعًا ، لذلك لا توجد مشكلة في الخطوة 1.

ومع ذلك ، عندما أحاول إعادة تسمية جميع علامات التبويب في وقت واحد ، أواجه تعارضًا - هناك ثلاث علامات تبويب تتعلق بحساب الضمان وأربع علامات تبويب تتعلق بالحساب العادي ، وهناك تقاطع في العملات بين الحسابات (يحتوي كل حساب على USD و EUR ، على سبيل المثال).

لدي حاليًا الرمز التالي لإعادة تسمية علامات التبويب: 

Sub RenameSheet ()
    Dim rs As Worksheet
    For Each rs In Sheets
        If rs.Index > 2 Then
            rs.Name = rs.Range("D4")
        End If
    Next rs
End Sub

ما أبحث عنه هو حل المشكلة: إذا كان الملف في مجلد معين (مثل ملف الماكرو) يحتوي على "حساب" ، فيجب تغيير قيمة الخلية في الخلية "D4" في علامة التبويب المدمجة في ملف ماكرو من "USD" (فليكن كشف حساب مصرفي بالدولار الأمريكي) إلى "Escrow USD". يجب أن يكون الماكرو قادرًا على فحص جميع الملفات في المجلد (هذا هو Loop ، بقدر ما أفهم) وإعادة تسمية الخلايا المحترمة في وقت واحد.

في ما يلي مثال للتعليمة البرمجية التي حاولت تدوينها (بدون سبب): 

Sub RenameSheet ()
    Dim fName As String, wb As Workbook, rs As Worksheet

    For Each rs In Sheets
        If rs.Index > 2 Then

            Const myPath As String = "C:\Users\my folder"
            If Right(myPath, 1) <> "\" Then fPath = myPath & "\"

            fName = Dir(fPath & "*Full*.xlsx*")
            v = "ESCROW"

            Do Until fName <> ""
                If InStr(1, fName, v) > 0 Then
                    rs.Name = "ESCROW" + rs.Range("D4")
                Else
                    rs.Name = rs.Range("D4")
                End If
            Loop

        End If
    Next rs

End Sub

إذا كان أي منكم يمكن أن يساعدني بطريقة ما ، سأكون ممتنًا. نرحب بأي أسئلة (أفهم أن لغتي يمكن أن تكون صعبة بعض الشيء).

تحديث. الكود الحالي لدمج علامات التبويب أدناه (مرة أخرى ، هذا ليس ملكي ، فقط غوغل وإدراجه في ملفي ، يعمل بشكل مثالي): 

Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook

    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

    If (vbBoolean <> VarType(fnameList)) Then

        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0

            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook

            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1

                Set wbkSrcBook = Workbooks.Open(FileName:=fnameCurFile)

                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    wksCurSheet.Copyafter:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Next

                wbkSrcBook.Close SaveChanges:=False

            Next

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic

            MsgBox "Procesed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If

    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

1 إجابة

0

هناك بعض الأشياء هنا وهناك قمت بتغييرها قبل الوصول إلى النقطة:

  • إعادة ترتيب بعض المتغيرات وإعادة تسميتها من أجل البساطة (نأمل)
  • تم تغيير عامل التصفية في المستندات إلى فقط *.xl* وأضاف مرشح ملف ثانوي لاحقًا مع Instr(file, ".xl")
  • استخدم With بيان لتغيير Application الإعدادات

ولكن ، يأتي الجزء الجديد المهم أثناء الحلقة على كل ورقة في المصنف المصدر. يقوم بإجراء الفحوصات التي استخدمتها في الشفرة الأولية - التحقق مما إذا كان الفهرس> 2 وما إذا كان "حساب الضمان" في اسم الملف - ثم يغير الاسم وفقًا لذلك عبر With بيان. 

Sub MergeExcelFiles()

    Dim fnameList, fnameCurFile As Variant
    Dim wbkDestBook, wbkCurSrcBook As Workbook
    Dim countFiles, countSheets As Long
    Dim wksCurSheet As Worksheet

    fnameList = Application.GetOpenFilename( _
        FileFilter:="Microsoft Excel Workbooks (*.xl*),*.xl*", _
        Title:="Choose Excel files to merge", _
        MultiSelect:=True)

    If (vbBoolean <> VarType(fnameList)) Then

        If (UBound(fnameList) > 0) Then

            With Application
                .ScreenUpdating = False
                .Calculation = xlCalculationManual
            End With

            Set wbkDestBook = ActiveWorkbook

            For Each fnameCurFile In fnameList
                If InStr(LCase$(fnameCurFile), ".xl") > 0 Then  'second file filter 'prevents e.g. shortcuts (.html files) that can get this far

                    Set wbkCurSrcBook = Workbooks.Open(filename:=fnameCurFile)

                    For Each wksCurSheet In wbkCurSrcBook.Sheets

                        wksCurSheet.copy after:=wbkDestBook.Sheets(wbkDestBook.Sheets.count)

                        'renaming here
                        If wbkDestBook.Sheets.count > 2 Then

                            With wbkDestBook.Sheets(wbkDestBook.Sheets.count)
                                If InStr(UCase$(fnameCurFile), "ESCROW") Then
                                    .Name = "ESCROW " & .Range("D4").Value2
                                Else
                                    .Name = .Range("D4").Value2
                                End If
                            End With

                        End If
                        'end of renaming

                        countSheets = countSheets + 1
                    Next

                    wbkCurSrcBook.Close SaveChanges:=False

                    countFiles = countFiles + 1
                End If
            Next

            With Application
                .ScreenUpdating = True
                .Calculation = xlCalculationAutomatic
            End With

            MsgBox "Procesed " & countFiles & " files." & vbCrLf & "Merged " & countSheets & " worksheets.", Title:="Merge Excel files"
        End If

    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If

End Sub
:مؤلف
مشاركة الرابط

أسئلة ذات صلة

أسئلة شائعة:

علامات السؤال:
excel-vba
loops
merge
filenames
فوق
قائمة طعام