复制单元格在一行并粘贴每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