Question

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

下面的代码将把“RES”列从Sheet2的“A1”开始（我无法弄清楚如何从第3行开始放置它）。它不会在标题中传输任何带有“B”的列。应该注意，字母“B”不必总是位于字符串的第一个位置。任何帮助深表感谢。

代码：

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

将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 2

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

您将搜索范围设置为A1：A4而不是A1：D1
您在代码中搜索A而不是B

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

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 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

使用表1至表2中的IF THEN语句传输数据

3 个答案: