使用IF THEN语句从表1到表2传输数据

我想将数据从sheet1传输到sheet2，如下图所示。 我认为最好使用if语句。 例如， ifsearch范围中的某个单元格等于“RES”， then在第一个空列的第3行开始的sheet2上包含“RES”的整个列。 ElseIFsearch范围中的下一个单元格中有一个“B”，然后将其中包含单元格的整个列放置在单元格2的“RES”列中的两列中，但将其他列放置为“B” B“放在最后一列之后，在sheet2上放一个”B“。

下面的代码将放置在“sheet2”上的“A1”开始的“RES”列（我不知道如何从第三行开始放置它）。 它不会传输标题中带有“B”的任何列。 应该注意的是，字母“B”不一定总是在string的第一位置。 任何帮助深表感谢。

码：

 Sub TransferValues() 'If statement Dim SrchRng As Range, cell As Range Dim lc As Long lc = Sheets("Sheet1").Cells(1, Columns.count).End(xlToLeft).Column Set SrchRng = Sheets("Sheet1").Range("A1:A" & lc & "") For Each cell In SrchRng If InStr(1, cell.Value, "RES") > 0 Then 'works Sheets("Sheet2").Range("A1").End(xlToLeft).Offset(3, 0).EntireColumn.Value = cell.EntireColumn.Value ElseIf InStr(1, cell.Value, "A", vbTextCompare) > 0 Then 'does not work Sheets("Sheet2").Range("A1").End(xlToLeft).Offset(0, 2).EntireColumn.Value = cell.EntireColumn.Value End If Next cell Application.DisplayAlerts = True End Sub 

Answer 1

我在代码中添加了一些注释和调整。

1. 您将search范围设置为A1：A4而不是A1：D1
2. 您在代码中searchA而不是B

3. 您使用的偏移量将放置在sheet2列C中的任何列B，所以我为该行添加了一个计数器。

    Sub TransferValues() 'Added counter Dim pasteColOffset As Long pasteColOffset = 0 'If statement Dim SrchRng As Range, cell As Range Dim lc As Long lc = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column 'This will set the seach range to A1:A4 'Set SrchRng = Sheets("Sheet1").Range("A1:A" & lc & "") Set SrchRng = Sheets("Sheet1").Range("A1").Resize(1, lc) For Each cell In SrchRng If InStr(1, cell.Value, "RES") > 0 Then 'works Sheets("Sheet2").Range("A3").End(xlToLeft).Offset(3, 0).EntireColumn.Value = cell.EntireColumn.Value pasteColOffset = pasteColOffset + 2 'This is looking for String "A" not String "B" 'ElseIf InStr(1, cell.Value, "A", vbTextCompare) > 0 Then 'does not work ElseIf InStr(1, cell.Value, "B", vbTextCompare) > 0 Then 'This will always place the data in column 3 maybe add a counter 'Sheets("Sheet2").Range("A1").End(xlToLeft).Offset(0, 2).EntireColumn.Value = cell.EntireColumn.Value Sheets("Sheet2").Range("A3").Offset(0, pasteColOffset).EntireColumn.Value = cell.EntireColumn.Value pasteColOffset = pasteColOffset + 1 End If Next cell Application.DisplayAlerts = True End Sub 

我没有在第3行处理粘贴，因为我已经没时间了，而是因为你正在使用整个列的属性而发生。 如果您不想粘贴整个列，您将无法使用整列，您将需要获取实际范围（高度可取）或在粘贴后插入上面的单元格。

Answer 2

将A1更改为A3 。
从

 Sheets("Sheet2").Range("A1").End(xlToLeft).Offset(3, 0).EntireColumn.Value = cell.EntireColumn.Value 

至

 Sheets("Sheet2").Range("A3").End(xlToLeft).Offset(3, 0).EntireColumn.Value = cell.EntireColumn.Value 

同样来自

 Sheets("Sheet2").Range("A1").End(xlToLeft).Offset(0, 2).EntireColumn.Value = cell.EntireColumn.Value 

至

 Sheets("Sheet2").Range("A3").End(xlToLeft).Offset(0, 2).EntireColumn.Value = cell.EntireColumn.Value 

Answer 3

 Sub TransferValues() Dim SrchRng As Range, cell As Range Dim cRange As Range, vRange As Range Dim xCol As Integer Dim lc As Long lc = Sheets("Sheet1").Range("a1").End(xlToRight).Column Set SrchRng = Sheets("Sheet1").Range("A1").Resize(1, lc) For Each cell In SrchRng If InStr(1, cell.Value, "RES") > 0 Then Set cRange = Range(cell, cell.End(xlDown)) Set vRange = Sheets("Sheet2").Range("A1").Offset(2, 0).Resize(cRange.Rows.Count, 1) vRange.Value = cRange.Value ElseIf InStr(1, cell.Value, "B", vbTextCompare) > 0 Then Set cRange = Range(cell, cell.End(xlDown)) xCol = 1 Do While Len(Sheets("sheet2").Range("A1").Offset(2, xCol)) > 0 xCol = xCol + 1 Loop Set vRange = Sheets("Sheet2").Range("A1").Offset(2, xCol).Resize(cRange.Rows.Count, 1) vRange.Value = cRange.Value End If Set cRange = Nothing Set vRange = Nothing Next cell Application.DisplayAlerts = True End Sub