複製單元格在一行並粘貼每n個細胞

Question

我有這幾個，我需要匹配的Excel文件。這是情況。

我得到的源文件，其中的新數據。在這種情況下，數據在59行，數值（數值）從C59開始，水平走向CB59。 有些值是特殊的，並以粗體顯示。 然後我有另一個文件，（目標）。數據在D列，從D9開始到D675，但數值是每9個單元格。 （D19，D18，D27等）。它們完美匹配。

我想要一個宏來查找源文件中的值並僅粘貼粗體值。 例如，如果我具有值在C59，D59，E59，F59中的源文件，在目標文件的等效將D9，D18，D27，D36，分別。 但是，如果只有D59和E59的值分別爲粗體，那麼這些將被複制到目標文件唯一的，在這種情況下，只有在價值觀和D18 D27會發生變化。 此外，如果複製的，它必須是在常信，不加粗。

感謝您的幫助。

更新： 請放棄大膽的數據。我剛剛發現我正在查找所有複製的數據。 我想問您的支持正確粘貼排58的數值，從我列wbBook2到CB柱，並將其粘貼在wbBook1，起始於D36和每一個細胞第九。

我試過這段代碼，它在wbBook 1 D36，D45和D54上粘貼了相同的wbBook2 I58值。然後，其餘的細胞每9個都是空白的，突然停在D243。

添加代碼

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

你有LastColumn尋找的最後一排。

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

應該

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

---

編輯：

我的測試代碼：

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：

我在閱讀時被誤解。我遍歷行並粘貼行;您希望與翻譯類似，遍歷列並粘貼行。在我的測試代碼

大廈，只需要將我從行移動到列在副本行：

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 

確保首選行，例如在啓動此測試代碼遍歷第1行中的列。

Answer 2

以下是我正在嘗試使用的新基於最後一個回覆的內容。

它仍然垂直複製（I58，I59，I60 ...）而不是水平（I58，J58，K58 ...）

我只是將引用更改爲適合每個源和目標文件的列和單元格。

我相信j是一個複製行而不是列的行。 我正在尋找選擇列H，用D和E以及複製和粘貼特殊計算公式。

UPDATE 此代碼的工作，但它停止就像進入最後一節列（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