根據條件復制/粘貼單元格范圍 x 次

Question

我想用精確范圍的數據填充電路板的每個空單元格。

我有兩張工作表；

- worksheets("Board")

- worksheets("FinalBoard")

在工作worksheets("Board")工作worksheets("Board")我有以下板；

類別	水果-1	水果-2	水果-3
一種	香蕉	櫻桃	橙色的
D	蘋果	芒果	草莓
乙	菠蘿	西瓜	手榴彈

僅當標題以“Fruits”開頭並將它們粘貼到工作worksheets("FinalBoard")一個列中時，我才想選擇每列數據。 我可以使用名為 Fruits 的列執行此操作，代碼如下；

Sub P_Fruits()

 Dim wsInput As Worksheet
    Dim wsOutput As Worksheet
    Dim lRowInput As Long
    Dim lRowOutput As Long
    Dim lCol As Long
    Dim i As Long
    Dim n As Long
    Dim s As String
    Dim col As String
    
    '~~>  Sheets settings
    Set wsInput = Sheets("Board")
    Set wsOutput = Sheets("FinalBoard")

       
With wsInput
        '~~> Find last column in Row 2
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        '~~> loop through columns
        For i = 1 To lCol
            '~~>  research criterias
            If .Cells(1, i).Value2 Like "Fruit-*" Then
                '~~> Get columns name
                col = Split(.Cells(, i).Address, "$")(1)
                
                '~~> Get the last row in that column
                lRowInput = .range(col & .Rows.Count).End(xlUp).row
                
                '~~> Find the next row to write to
               If lRowOutput = 0 Then
                    lRowOutput = 2
               Else
                    lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
                End If
                
                '~~> Copy-paste in the 2nd worksheet every data if the headers is found
                .range(col & "2:" & col & lRowInput).Copy _
                wsOutput.range("B" & lRowOutput)
                
      
            End If
      Next i
end with

end sub 

但是我想為“類別”列這樣做，並將類別的類型放在 A 列中每個水果的前面，從而多次重復復制的范圍類別，就像worksheets("Board")以“水果”開頭的標題一樣多worksheets("Board") 。 我試圖在前一個代碼中添加一個額外的代碼，但沒有用。 這是我想要的結果；

分類粘貼	果醬
一種	香蕉
D	蘋果
乙	菠蘿
一種	櫻桃
D	瓜
乙	西瓜
一種	橙色的
D	草莓
乙	手榴彈

這是我添加的代碼的內容......

分類粘貼	果醬
	香蕉
	蘋果
	菠蘿
	櫻桃
	瓜
	西瓜
	橙色的
	草莓
	手榴彈
一種
D
乙

我的結局代碼；

Sub Fruits_add()

 Dim wsInput As Worksheet
    Dim wsOutput As Worksheet
    Dim lRowInput As Long
    Dim lRowOutput As Long
    Dim lCol As Long
    Dim i As Long
    Dim n As Long
    Dim s As String
    Dim col As String
    
    '~~>  Sheets settings
    Set wsInput = Sheets("Board")
    Set wsOutput = Sheets("FinalBoard")

       
With wsInput
        '~~> Find last column in Row 2
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        '~~> loop through columns
        For i = 1 To lCol
            '~~>  research criterias
            If .Cells(1, i).Value2 Like "Fruit-*" Then
                '~~> Get column name
                col = Split(.Cells(, i).Address, "$")(1)
                
                '~~> Get the last row in that column
                lRowInput = .range(col & .Rows.Count).End(xlUp).row
                
                '~~> Find the next row to write to
               If lRowOutput = 0 Then
                    lRowOutput = 2
               Else
                    lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
                End If
                
                '~~> Copy-paste
                .range(col & "2:" & col & lRowInput).Copy _
                wsOutput.range("B" & lRowOutput)
                
      
            End If
      Next i
      
 'Code to repeat category type added     
With wsInput
        '~~> Find last column in Row 2
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        '~~> loop through columns
        For i = 1 To lCol
        
         '~~>  research criterias
            If .Cells(1, i).Value2 Like "Category*" Then
                '~~> Get column name
                col = Split(.Cells(, i).Address, "$")(1)
                
                '~~> Get the last row in that column
                lRowInput = .range(col & .Rows.Count).End(xlUp).row
                
                '~~> Find the next row to write to
               If lRowOutput = 0 Then
                    lRowOutput = 2
               Else
                    lRowOutput = wsOutput.range("A" & wsOutput.Rows.Count).End(xlUp).row + 1
                End If
                
                '~~> copy-paste each category type in column A
                .range(col & "2:" & col & lRowInput).Copy _
                wsOutput.range("A" & lRowOutput)
                
                
                
         End If
      Next i
End With

      
      
End With

我覺得我已經接近解決方案了。 我很感激你們的幫助，謝謝！

Answer 1

此代碼將產生所需的結果，但使用不同的方法。

它做的第一件事是將源數據讀入一個數組，然后遍歷該數組並從每個列中提取水果/類別，標題以“Fruit”開頭。

Option Explicit

Sub Fruits_add()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim arrDataIn As Variant
Dim arrDataOut As Variant
Dim idxCol As Long
Dim idxRow As Long
Dim cnt As Long

    '~~>  Sheets settings
    Set wsInput = Sheets("Board")
    Set wsOutput = Sheets("FinalBoard")

    ' assumes data on 'Board' starts in A1
    With wsInput
        arrDataIn = .Range("A1").CurrentRegion.Value
    End With
    
    ReDim arrDataOut(1 To 2, 1 To UBound(arrDataIn, 1) * UBound(arrDataIn, 2))
    
    For idxCol = LBound(arrDataIn, 2) To UBound(arrDataIn, 2)
        If arrDataIn(1, idxCol) Like "Fruits*" Then
            For idxRow = LBound(arrDataIn, 1) + 1 To UBound(arrDataIn, 1)
                cnt = cnt + 1
                arrDataOut(1, cnt) = arrDataIn(idxRow, 1)
                arrDataOut(2, cnt) = arrDataIn(idxRow, idxCol)
            Next idxRow
        End If
    Next idxCol
    
    If cnt > 0 Then
        ReDim Preserve arrDataOut(1 To 2, 1 To cnt)
    End If
    
    With wsOutput
        .Range("A1:B1").Value = Array("Category-pasted", "Fruit-pasted")
        .Range("A2").Resize(cnt, 2) = Application.Transpose(arrDataOut)
    End With
    
End Sub

Answer 2

正如我在評論中所解釋的，如果您已經找到正確的行，則不需要第二個循環 - 盡早獲取類別列並稍后重用

您可以先在頂部添加此變量聲明

Dim col As String

然后繼續執行第一個循環的代碼（刪除第二個循環

With wsInput
        '~~> Find last column in Row 2
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        '~~> loop through columns
        For i = 1 To lCol

添加此項以首先檢索類別

            If .Cells(1, i).Value2 Like "Category*" Then
            '~~> Get column name
               colCat = Split(.Cells(, i).Address, "$")(1)                
            End If

            '~~>  research criterias
            If .Cells(1, i).Value2 Like "Fruit-*" Then
                '~~> Get column name
                col = Split(.Cells(, i).Address, "$")(1)
                
                '~~> Get the last row in that column
                lRowInput = .range(col & .Rows.Count).End(xlUp).row
                
                '~~> Find the next row to write to
               If lRowOutput = 0 Then
                    lRowOutput = 2
               Else
                    lRowOutput = wsOutput.range("B" & wsOutput.Rows.Count).End(xlUp).row + 1
                End If
                
                '~~> Copy-paste
                .range(col & "2:" & col & lRowInput).Copy _
                wsOutput.range("B" & lRowOutput)
                

然后添加它以粘貼類別

            '~~> copy-paste each category type in column A
            .range(colCat & "2:" & colCat & lRowInput).Copy _
            wsOutput.range("A" & lRowOutput)
      
            End If
      Next i
End With