Consulting

Results 1 to 3 of 3

Thread: Vba : copy Transpose in 2 differents rows

  1. #1

    Vba : copy Transpose in 2 differents rows

    Hi,

    I am a beginner and for my first code I would to achieve a copy and transpose on 2 different rows, in function of an argument :
    Exp : copy value in range A1:A8 if value in column B = "good" and paste in Range C1:F1 and Range C2:F2, avoiding blank and repetition in 2 ranges.

    I started with that :

    Sub Try()
    Dim x As Integer
    
        For x = 1 To 4
    
            If Worksheets("sheet1").Range("B" & x) = "good" Then
    
                Worksheets("sheet1").Range("A" & x).Copy
                lastrow = Worksheets("sheet1").Range("J" & Rows.Count).End(xlUp).Row
    	    Worksheets("sheet1").Range("J" & lastrow + 1).PasteSpecial Paste:=xlPasteValues
    	End If
        Next x
    
        Worksheets("sheet1").Range("J2:J5").Copy
        Worksheets("sheet1").Range("C1:F1").PasteSpecial transpose:=True
        Range("J2:J5").ClearContents
    
        For x = 5 To 8
    
            If Worksheets("sheet1").Range("B" & x) = "good" Then
    	
                Worksheets("sheet1").Range("A" & x).Copy
                lastrow = Worksheets("sheet1").Range("J" & Rows.Count).End(xlUp).Row
                Worksheets("sheet1").Range("J" & lastrow + 1).PasteSpecial Paste:=xlPasteValues
    	End If
        Next x
    
        Worksheets("sheet1").Range("J2:J5").Copy
        Worksheets("sheet1").Range("C2:F2").PasteSpecial transpose:=True
        Range("J2:J5").ClearContents
    End Sub
    but I think it's pretty slown to run and I have still blank cells.

    I was thinking doing an offset after :

    Dim cell As Range
    
    	For Each cell In Active	Sheet.Range("C1:F1")
        
    		If IsEmpty(cell) Then
    			cell.Value = cell.offset(1, -1).Value
    		End If
    	Next cell
    But I end up with repetition on the same values.

    I hope it's clear enough and if someone can help me. thank you.
    Last edited by Bob Phillips; 06-16-2021 at 02:35 PM. Reason: Added code tags

  2. #2
    Sub Maybe()
    If Cells(1, 2).Value = "good" Then
        Cells(1, 3).Resize(, 4).Value = Application.Transpose(Cells(1, 1).Resize(4).Value)
        Cells(2, 3).Resize(, 4).Value = Application.Transpose(Cells(5, 1).Resize(4).Value)
    End If
    End Sub

  3. #3
    Or so?
    Sub Maybe_So()
    Dim ii As Long, i As Long, jj As Long, j As Long
    ii = 3
        For i = 1 To 4
            If Cells(i, 2).Value = "good" Then Cells(1, ii).Value = Cells(i, 1).Value: ii = ii + 1
        Next i
    jj = 3
        For j = 5 To 8
            If Cells(j, 2).Value = "good" Then Cells(2, jj).Value = Cells(j, 1).Value: jj = jj + 1
        Next j
    End Sub

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •