Copiez les cellules d'affilée et collez toutes les nièmes cellules

Question

J'ai ce couple de fichiers Excel que je dois faire correspondre. Voici la situation.

J'ai obtenu le fichier source, où les nouvelles données sont. Dans ce cas, les données sont à la rangée 59 et les valeurs (numériques) commencent à C59 et vont horizontalement jusqu'à CB59. Certaines valeurs sont spéciales et sont en gras. Ensuite, j'ai l'autre fichier, (cible). Les données sont à la colonne D, commençant à D9 et passe à D675, mais les valeurs sont toutes les 9 cellules. (D19, D18, D27, etc.). Ils correspondent parfaitement.

Je voudrais avoir une macro pour rechercher les valeurs dans le fichier source et coller UNIQUEMENT les valeurs en gras. Par exemple, si j'ai les valeurs C59, D59, E59, F59 dans le fichier source, l'équivalent dans le fichier cible serait respectivement D9, D18, D27, D36. Cependant, si seulement D59 et E59 ont les valeurs en gras, alors celles-ci seront les seules copiées dans le fichier cible, dans ce cas, seules les valeurs à D18 et D27 changeront. En outre, si copié, il doit être en lettre régulière, pas en gras.

Merci pour votre aide.

MISE À JOUR: Veuillez supprimer les données en gras. Je viens de trouver que je cherche toutes les données copiées. Je voudrais demander votre soutien pour coller correctement les valeurs de la ligne 58, de la colonne I à la colonne CB dans wbBook2, et les coller dans le wbBook1, à partir de D36 et toutes les 9 cellules.

J'ai essayé ce code et il colle la même valeur de wbBook2 I58 sur wbBook 1 D36, D45 et D54. Ensuite, le reste des cellules tous les 9 sont vides, et tout à coup, il s'arrête à D243.

CODE AJOUT

Sub Macroloco_() 

Dim wbBook1 As Workbook 

Dim wbBook2 As Workbook 

Set wbBook1 = ThisWorkbook 
Set wbBook2 = Workbooks.Open("C:\reports Sep\week38.xls") 

Dim wsSheet1 As Worksheet 
Dim wsSheet2 As Worksheet 
Set wsSheet1 = wbBook1.Worksheets("01") 
Set wsSheet2 = wbBook2.Worksheets("results") 

Dim lastColumn As Long 
Dim targetRow As Long 
Dim i As Long 

targetRow = 36 

lastColumn = wsSheet2.Range("CB" & Columns.Count).End(xlUp).Column 
For i = 58 To lastColumn 
wsSheet2.Range("I" & i).Copy 
wsSheet1.Range("D" & targetRow).PasteSpecial xlPasteAll 

targetRow = targetRow + 9 

Next i 

End Sub 

Answer 1

Vous avez la LastColumn la recherche de la dernière ligne.

lastColumn = wsSheet2.Range("CB" & Columns.Count).End(xlUp).Column 

Devrait être

With wsSheet2 
    lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column 
End With 

---

Edit:

Mon test codE:

Sub fdsa() 

    Dim i As Long, j As Long, k As Long 
    With Sheets("Sheet1") 
     j = .Cells(1, .Columns.Count).End(xlToLeft).Column 
     k = 1 
     For i = 1 To j 
      .Cells(i, 1).Copy 
      Sheets("Sheet2").Cells(k, 4).PasteSpecial xlPasteAll 
      k = k + 1 
     Next i 
    End With 
End Sub 

Edit2:

J'ai mal compris en lisant. Je parcourais des rangées et je collais en rangées; vous souhaitez, comme pour la traduction, parcourir les colonnes et les coller dans les lignes.

bâtiment sur mon code de test, il suffit de déplacer le i de la ligne à la colonne dans la ligne de copie:

Sub fdsa() 
    Dim i As Long, j As Long, k As Long 
    With Sheets("Sheet1") 
     j = .Cells(1, .Columns.Count).End(xlToLeft).Column 
     k = 1 
     For i = 1 To j 
      .Cells(1, i).Copy 'changed to copy the iterating COLUMN 
      Sheets("Sheet2").Cells(k, 4).PasteSpecial xlPasteAll 'Still pastes in every 9th ROW 
      k = k + 1 
     Next i 
    End With 
End Sub 

Assurez-vous de commencer dans la ligne préférée, par exemple ce code de test parcourt les colonnes de la ligne 1.

Answer 2

Voici le nouveau que j'essaie, basé sur la dernière réponse. Il copie encore verticalement (I58, I59, I60 ...) au lieu d'horizontalement (I58, J58, K58 ...). Il copie toujours verticalement (I58, I59, I60 ...)

Je viens de changer les références pour aller aux colonnes et aux cellules appropriées par fichier source et cible.

Je crois que j est celui qui copie les rangées au lieu des colonnes. Je cherche à sélectionner la colonne H, calculer une formule avec D et E et le copier et coller spécial.

MISE À JOUR Ce code fonctionne mais il arrête aussi entrer dans les colonnes de dernière section (H: H)

Sub Macroloco_() 
Dim wbBook1 As Workbook 
Dim wbBook2 As Workbook 

Set wbBook1 = ThisWorkbook 
Set wbBook2 = Workbooks.Open("C:\reports Sep\week38.xls") 

Dim wsSheet1 As Worksheet 
Dim wsSheet2 As Worksheet 
Set wsSheet1 = wbBook1.Worksheets("01") 
Set wsSheet2 = wbBook2.Worksheets("report") 

Dim i As Long, j As Long, k As Long 
With wsSheet2 
    j = .Cells(1, .Columns.Count).End(xlToLeft).Column 
    k = 36 
    For i = 9 To j 
     .Cells(58, i).Copy 
     wsSheet1.Cells(k, 4).PasteSpecial xlPasteAll 
     k = k + 9 
    Next i 
End With 

Columns("H:H").Select 
Selection.SpecialCells(xlCellTypeConstants, 1).Select 
Selection.FormulaR1C1 = "=RC[-4]-RC[-3]" 
Columns("H:H").Select 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
Columns("I:I").Select 
Selection.SpecialCells(xlCellTypeConstants, 1).Select 
Selection.ClearContents 
Range("J9").Select 
Application.CutCopyMode = False 

End Sub