Excel VBA - Déplacer des données basées sur la numérotation

Question

Je dois déplacer des données d'Excel 1 vers un autre excel basé sur le format de numérotation. Pour un exemple que j'ai échantillons test1 excellent comme ci-dessous:

test1.xlsx

EName| Sal | ID | Tel | Add  | Depart  | Pos  | 
------------------------------------------------------------ 
John | 10000 | 123| NA | NY  | Finance | Manager | 
------------------------------------------------------------ 
    1 | 5 | 2 |  |   | 3  | 4  | 

colonne disposés en nombre. Je dois déplacer mes données vers un autre Excel dans ce cas test2 et coller au format de numérotation.

test.xlsx

Name | ID | Department | Level  |Position | Salary | 
    1 | 2 |  3  |   | 4  | 5 | 
John | 123| Fiinanace | NA  |Manager | 10000 | 

valeur pour chaque colonne identifiée par les numéros. Comment puis-je y parvenir. Tous les conseils/références sont très appréciés. Merci

Sub startGenerateExcel() 
Path1 = Range("F4").Value 
Path2 = Range("F6").Value 

Dim wbSource As Workbook 
Dim wbDest As Workbook 
Dim rngSource As Range 
Dim rngDest As Range 
Dim colNum As Integer 
Dim colDest As Integer 
Dim cl As Range 

Set wbSource = Workbooks(Path1) 
Set wbDest = Workbooks(Path2) 

Set rngSource = wbSource.Sheets("Sheet1").Range("A1:G3") 'Modify as needed 
Set rngDest = wbDest.Sheets("Sheet1").Range("A1:F3") 'Modify as needed 

For Each cl In rngSource.Rows(2) 
    colNum = cl.Offset(1, 0).Value 
    colDest = Application.Match(colNum, rngDest.Rows(3), False) 
    rngDest.Cells(2, colDest).Value = cl.Value 
Next 
End Sub 

Answer 1

Ceci n'a pas été testé mais doit fondamentalement fonctionner. J'utilise la fonction Match pour faire ce genre de chose tout le temps. Vous devrez modifier pour vos besoins spécifiques, à savoir, en supposant que vos tables sont plus que 3 lignes, etc.

Sub TransferValuesUsingMatch() 

Dim wbSource as Workbook 
Dim wbDest as Workbook 
Dim rngSource as Range 
Dim rngDest as Range 
Dim colNum as Integer 
Dim colDest as Integer 
Dim cl as Range 

Set wbSource = Workbooks("test1.xlsx") 'Assumes the workbook is already open 
Set wbDest = Workbooks("test.xlsx") 'Assumes the workbook is already open 
Set rngSource = wbSource.Sheets("Sheet1").Range("A1:G3") 'Modify as needed 
Set rngDest = wbDest.Sheets("Sheet1").Range("A1:F3") 'Modify as needed 

For each cl in rngSource.Rows(2) 
    colNum = cl.Offset(1,0).Value 
    colDest = Application.Match(colNum, rngDest.Rows(3), False) 
    rngDest.Cells(2,colDest).Value = cl.Value 
Next 

End Sub 

Answer 2

Je ne sais pas si vous voulez réorganiser les lignes trop ou si vous des exemples seulement J'ai les chiffres pour l'illustration, mais je suppose que vous voulez juste déplacer des colonnes de données basées sur les noms de la ligne d'en-tête. J'aime tirer des données des feuilles Excel et mettre ces données dans un tableau. Faites quelque chose pour les données, puis remettez-les dans une feuille Excel. C'est plus rapide que de travailler dans les cellules et cela fonctionnera bien dans ce cas. Voir http://www.cpearson.com/excel/ArraysAndRanges.aspx pour un exemple de code sur la façon de le faire.

Vous pouvez placer chaque colonne dans son propre tableau, puis utiliser les valeurs de la position (1, 1) pour les réorganiser dans le fichier de destination. Vous pouvez ajuster cette position pour répondre à vos besoins s'il existe une autre ligne contenant les informations de commande.

Answer 3

Essayez le code suivant. Il lit les données de la "vieille" feuille de calcul dans un tableau, écrit les données réorganisées dans un nouveau tableau, puis affecte les valeurs du nouveau tableau à la "nouvelle" feuille de calcul.

Sub CopyAndRearrange() 

    Dim oldWkb As Workbook, newWkb As Workbook 
    Dim oldRange As Range, newRange As Range 
    Dim oldArr(), newArr() 

    'Assume data are in Sheet1 in oldWkb and need to go to Sheet1 in newWkb 
    'and that both workbooks are open 
    Set oldWkb = Workbooks("aWkb.xlsm") 
    Set newWkb = Workbooks("anotherWkb.xlsm") 
    Set oldRange = oldWkb.Worksheets(1).Range("A2:G11") 
    Set newRange = newWkb.Worksheets(1).Range("A2:F11") 
    Dim i As Long, j As Long 

' Assume data have fixed, known dimensions 
    ReDim oldArray(1 To 10, 1 To 7) 
    oldArray = oldRange 
    ReDim newArray(1 To 10, 1 To 6) 
    For i = 1 To 10 
     For j = 1 To 6 
      Select Case j 
       Case 1 
        newArray(i, 1) = oldArray(i, 1) '1->1 
       Case 2 
        newArray(i, 6) = oldArray(i, 2) '2->6 
        Debug.Print newArray(i, 6) 
       Case 3 
        newArray(i, 2) = oldArray(i, 3) '3->2      
       Case 4 
        newArray(i, 3) = oldArray(i, j + 2) '6->3 
       Case 5 
        newArray(i, 5) = oldArray(i, j + 2) '7->5 
       Case 6 
        newArray(i, 4) = "NA"    'NA->4 
      End Select 
     Next j 
    Next i 
    newRange.Value = newArray 

End Sub 

Answer 4

I votre code, remplacez For ... Next avec:

For Each cl In rngSource.Rows 'Handle whole row at once! 
    rngDest.Cells(cl.Row, 1).Resize(, 6) = Array(cl.Cells(, 1), cl.Cells(1, 3), cl.Cells(1, 6), Empty, cl.Cells(1, 7), cl.Cells(1, 2)) 
Next