Astuces Excel
  1. Astuces Excel
  3. Fusionner datatables du classur différent en feuille spécifique du classur principal
Intereting Posts
Définir une valeur de cellule à partir d'une fonction Mettre en surbrillance la valeur dupliquée à partir de la seconde instance avec la couleur rouge, de la gamme des trous (UsedRange) blocage des mesures implicites dans powerpivot / tabular Sendkey ("{ENTER}") ne fonctionne pas lors de l'automation d'Internet Explorer Je ne comprends pas le formulaire Excel Erreur de déséquilibre de type macro Excel Excel Macro Plusieurs feuilles à CSV Suppression d'un file Excel en C #, le process Taskmanager n'est pas arrêté Essayer d'extraire des données des appareils orthodontiques mais ne pas fonctionner Format du file text afin que je puisse l'importer dans Excel Comment insert du text dans une textbox (feuille de calcul) à l'aide de VBA dans Excel? Excel VBA: Copier des lignes d'un autre classur, mais seulement les résultats de la fonction algorithm d'exploration de données qui suggère cette situation Suppression du mot de passe Excel Table Excel – sélection d'une colonne via = CONCATENATE ()

Fusionner datatables du classur différent en feuille spécifique du classur principal

Je veux merge un contenu de la feuille de calcul nommé «Suivi des tâches» à partir de 3 classurs différents nommés Sub WB1, Sub WB2 et Sub WB3 dans une seule feuille de travail de suivi des tâches de Mainbooks. Aidez-nous.

Il existe 4 classurs au total avec 12 feuilles de calcul dans chacune.

  • Ouvrage principal
  • Sub WB1
  • Sub WB2
  • Sub WB3

Je veux merge datatables du «Suivi des tâches» (nom de la feuille de travail) de Sub WB1, Sub WB2 et Sub WB3 dans le classur principal en utilisant un button Consolider dans le classur principal.

J'ai utilisé le code ci-dessous que j'ai obtenu à partir d'une reference, mais je reçois Runtime Error: 1004. Aidez-vous. 

Sub MergeSpecificWorkbooks() Dim MyPath As Ssortingng Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long Dim SaveDriveDir As Ssortingng Dim FName As Variant 'Change ScreenUpdating, Calculation and EnableEvents With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'SaveDriveDir = CurDir 'ChDirNet "D:\DD_Task1\" path = "D:\DD_Task1\" 'FName = Application.GetOpenFilename("Sub WB1.xls, Sub WB2.xls, Sub WB3.xls", MultiSelect:=True) FName = Application.GetOpenFilename(filefilter:="Sub WB1.xlsm, Sub WB2.xlsm, Sub WB3.xlsm", _ MultiSelect:=True) If IsArray(FName) Then 'Add a new workbook with one sheet 'Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) Set BaseWks = Worksheets.Add BaseWks.Name = "Master" rnum = 2 'Loop through all files in the array(myFiles) For FNum = LBound(FName) To UBound(FName) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(FName(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next With mybook.Worksheets("H-POD") .Unprotect LC = .Cells(.Rows.Count, "C").End(xlUp).Row Set sourceRange = .Range("B10:M" & LC) End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else 'if SourceRange use all columns then skip this file If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet" BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else 'Copy the file name in column A With sourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = FName(FNum) End With 'Set the destrange Set destrange = BaseWks.Range("B" & rnum) 'we copy the values from the sourceRange to the destrange With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close savechanges:=False End If Next FNum BaseWks.Columns.AutoFit End If ExitTheSub: 'Restore ScreenUpdating, Calculation and EnableEvents With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With ' ChDirNet SaveDriveDir End Sub

GetOpenFilename() méthode GetOpenFilename() n'accepte pas une FileFilter syntaxe FileFilter comme "Sub WB1.xlsm, Sub WB2.xlsm, Sub WB3.xlsm"

Si vous souhaitez que l'user sélectionne uniquement des files avec des noms, vous devez utiliser un UserForm

Par exemple, vous pouvez agir comme suit:

  • changement: 

     FName = Application.GetOpenFilename("Sub WB1.xls, Sub WB2.xls, Sub WB3.xls", MultiSelect:=True)

    à: 

     FName = GetFName()

  • ajoutez la Function suivante (peut-être dans le même module que celui de votre sous) 

     Function GetFName() As Variant Dim iList As Long Dim selectedFiles As Ssortingng With ListFiles_UF With .ListBox1 .MultiSelect = fmMultiSelectMulti .List = Array("Sub WB1.xlsm", "Sub WB2.xlsm", "Sub WB3.xlsm") End With .Show With .ListBox1 If .ListIndex > 0 Then For iList = 0 To .ListCount - 1 If .Selected(iList) Then selectedFiles = selectedFiles & .List(iList) & "|" Next GetFName = Split(Left(selectedFiles, Len(selectedFiles) - 1), "|") End If End With End With End Function

  • ajoutez un UserForm à votre projet VBA et nommez-le après "ListFiles_UF" (vous pouvez choisir n'importe quel autre nom valide mais être cohérent avec tout le code)

  • placez un contrôle ListBox (par défaut nommé après "ListBox1") et un contrôle CommandButton (par défaut appelé "CommandButton1") dans la forme d'user "ListFiles_UF"

  • placez ce code dans le panneau de code "ListFiles_UF" 

     Private Sub CommandButton1_Click() Me.Hide End Sub