How to filter and copy data from one sheat to another and transpose

[Bascream]

So, I have a excel file with lots of data.

in sheet 1 column K I have a the date in where i wish to locate certain text (the text in the cell is a lot and I need to search on a single word in the string of text).
when all cells are found containing the word i need to copy the corresponding cell in column D to another sheet and transpose

so if the search yield 5 rows i need to copy and transpose the 5 fields in another sheet in 5 columns.

I hope that my explenation is enough and clear for you to help me out.

 

[Muhammad_Usman]

Sub CopyAndTranspose()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim lastRow As Long
    Dim searchWord As String
    Dim i As Long
    Dim j As Long
    
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Sheets("Sheet1") ' Change to your source sheet name
    Set wsDestination = ThisWorkbook.Sheets("Sheet2") ' Change to your destination sheet name
    
    ' Specify the word you want to search for
    searchWord = "YourWord" ' Change to the word you're looking for
    
    ' Find the last row in column K of the source sheet
    lastRow = wsSource.Cells(wsSource.Rows.Count, "K").End(xlUp).Row
    
    ' Initialize row counter for the destination sheet
    j = 1
    
    ' Loop through the cells in column K
    For i = 1 To lastRow
        If InStr(1, wsSource.Cells(i, "K").Value, searchWord, vbTextCompare) > 0 Then
            ' If the word is found, copy the corresponding value from column D
            wsDestination.Cells(j, 1).Value = wsSource.Cells(i, "D").Value
            j = j + 1 ' Move to the next row in the destination sheet
        End If
    Next i
    
    ' Transpose the data from rows to columns in the destination sheet
    wsDestination.Cells(1, 1).Resize(j - 1, 1).Copy
    wsDestination.Cells(1, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    
    ' Clear clipboard
    Application.CutCopyMode = False
End Sub

Please make sure to update the following parts of the code as needed:

• searchWord to the word you want to search for within the text in column K.
• wsSource and wsDestination to match the names of your source and destination sheets.
• You can adjust the destination starting cell (wsDestination.Cells(j, 1)) as needed.

After making these adjustments, you can run the code in the VBA editor in Excel. This code will search for the specified word in the text in column K of Sheet 1, copy the corresponding values from column D to Sheet 2, and transpose the copied data.

 

[Bascream]

Hey,
thnx for the code, works very well but a added question occurs now:

Is it possible to let it past the transposed alone and in a certain cell (let's say worksheet 1 cell C5):

at this moment it first paste the data in cells under each other and after it it transposes the data

 

[Muhammad_Usman]

Hey,
thnx for the code, works very well but a added question occurs now:

Is it possible to let it past the transposed alone and in a certain cell (let's say worksheet 1 cell C5):

at this moment it first paste the data in cells under each other and after it it transposes the data

Check this code

Sub CopyAndTranspose()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim lastRow As Long
    Dim searchWord As String
    Dim i As Long
    Dim j As Long
    Dim dataToTranspose() As Variant
    
    ' Set source and destination worksheets
    Set wsSource = ThisWorkbook.Sheets("Sheet1") ' Change to your source sheet name
    Set wsDestination = ThisWorkbook.Sheets("Sheet2") ' Change to your destination sheet name
    
    ' Specify the word you want to search for
    searchWord = "YourWord" ' Change to the word you're looking for
    
    ' Find the last row in column K of the source sheet
    lastRow = wsSource.Cells(wsSource.Rows.Count, "K").End(xlUp).Row
    
    ' Initialize row counter for the destination sheet
    j = 1
    
    ' Loop through the cells in column K and store values in the array
    For i = 1 To lastRow
        If InStr(1, wsSource.Cells(i, "K").Value, searchWord, vbTextCompare) > 0 Then
            ' If the word is found, store the corresponding value from column D in the array
            dataToTranspose(j) = wsSource.Cells(i, "D").Value
            j = j + 1
        End If
    Next i
    
    ' Transpose the data from rows to columns in the destination sheet starting from C5
    wsDestination.Cells(5, 3).Resize(j - 1, 1).Value = Application.Transpose(dataToTranspose)
End Sub