Copy information from one sheet to other sheet like transpose

[vinzent]

Hi to all

I am learning VBA and I need you help: I am trying to copy the information from Data Tab to Table tab, but I need to put all the rows for the material in only one row (like transpose). Just only with one condition: the data with information "Not short" in column L is not considered.

I upload the file to best reference and put the tab Example as reference (in manual mode).
Any idea or if you can help me, thank you

DONWLOAD THE EXAMPLE HERE

 

[Fluff]

How about

Sub vinzent()
   Dim Rng As Range, Cl As Range, Dest As Range
   Dim Ows As Worksheet
   Dim i As Long
   
   Set Ows = Sheets("Original")
   
   For Each Rng In Sheets("Data").Range("A:A").SpecialCells(xlBlanks).Areas
      i = 31
      Set Rng = Rng.Offset(-1).Resize(Rng.Count + 1)
      Set Dest = Ows.Range("T:T").Find(Rng(1).Value, , , xlWhole, , , False, , False)
      If Dest Is Nothing Then
         Set Dest = Ows.Range("T" & Rows.Count).End(xlUp).Offset(1)
         Dest.Value = Rng(1).Value
      End If
      For Each Cl In Rng
         If Cl.Offset(, 11) <> "Not short" Then
            Cl.Offset(, 1).Resize(, 5).Copy Dest.Offset(, i)
            i = i + 5
         End If
      Next Cl
   Next Rng
End Sub

 

[vinzent]

How about

Sub vinzent()
   Dim Rng As Range, Cl As Range, Dest As Range
   Dim Ows As Worksheet
   Dim i As Long
   
   Set Ows = Sheets("Original")
   
   For Each Rng In Sheets("Data").Range("A:A").SpecialCells(xlBlanks).Areas
      i = 31
      Set Rng = Rng.Offset(-1).Resize(Rng.Count + 1)
      Set Dest = Ows.Range("T:T").Find(Rng(1).Value, , , xlWhole, , , False, , False)
      If Dest Is Nothing Then
         Set Dest = Ows.Range("T" & Rows.Count).End(xlUp).Offset(1)
         Dest.Value = Rng(1).Value
      End If
      For Each Cl In Rng
         If Cl.Offset(, 11) <> "Not short" Then
            Cl.Offset(, 1).Resize(, 5).Copy Dest.Offset(, i)
            i = i + 5
         End If
      Next Cl
   Next Rng
End Sub

It's working!! just a quick question: How can I modify to get the information if in tab Data column Material i have only one row and need to put only this line?

 

[Fluff]

If I delete everything except row 2, then that row is copied across to the Original sheet.

 

[vinzent]

If I delete everything except row 2, then that row is copied across to the Original sheet.

For Data10, I deleted row 3 & 4 , only showing row 2 and run the macro, but the information was not copied. I missing something?

 

[Fluff]

Got you. Try

Sub vinzent()
   Dim Rng As Range, Cl As Range, Dest As Range
   Dim Ows As Worksheet
   Dim i As Long, j As Long
   
   Set Ows = Sheets("Original")
   
   For Each Rng In Sheets("Data").Range("A:A").SpecialCells(xlBlanks).Areas
      i = 31
      Set Rng = Rng.Offset(-1).Resize(Rng.Count + 1)
      Set Dest = Ows.Range("T:T").Find(Rng(1).Value, , , xlWhole, , , False, , False)
      If Dest Is Nothing Then
         Set Dest = Ows.Range("T" & Rows.Count).End(xlUp).Offset(1)
         Dest.Value = Rng(1).Value
      End If
      For Each Cl In Rng
         If Cl.Offset(, 11) <> "Not short" Then
            Cl.Offset(, 1).Resize(, 5).Copy Dest.Offset(, i)
            i = i + 5
         End If
      Next Cl
   Next Rng
   For Each Rng In Sheets("Data").Range("A2:A" & Rows.Count).SpecialCells(xlConstants).Areas
      i = 31
      For j = 1 To Rng.Count - 1
         Set Dest = Ows.Range("T:T").Find(Rng(1).Value, , , xlWhole, , , False, , False)
         If Dest Is Nothing Then
            Set Dest = Ows.Range("T" & Rows.Count).End(xlUp).Offset(1)
            Dest.Value = Rng(1).Value
         End If
         If Rng(j).Offset(, 11) <> "Nort short" Then
            Rng(j).Offset(, 1).Resize(, 5).Copy Dest.Offset(, i)
         End If
      Next j
   Next Rng
End Sub

 

[vinzent]

Got you. Try

Sub vinzent()
   Dim Rng As Range, Cl As Range, Dest As Range
   Dim Ows As Worksheet
   Dim i As Long, j As Long
   
   Set Ows = Sheets("Original")
   
   For Each Rng In Sheets("Data").Range("A:A").SpecialCells(xlBlanks).Areas
      i = 31
      Set Rng = Rng.Offset(-1).Resize(Rng.Count + 1)
      Set Dest = Ows.Range("T:T").Find(Rng(1).Value, , , xlWhole, , , False, , False)
      If Dest Is Nothing Then
         Set Dest = Ows.Range("T" & Rows.Count).End(xlUp).Offset(1)
         Dest.Value = Rng(1).Value
      End If
      For Each Cl In Rng
         If Cl.Offset(, 11) <> "Not short" Then
            Cl.Offset(, 1).Resize(, 5).Copy Dest.Offset(, i)
            i = i + 5
         End If
      Next Cl
   Next Rng
   For Each Rng In Sheets("Data").Range("A2:A" & Rows.Count).SpecialCells(xlConstants).Areas
      i = 31
      For j = 1 To Rng.Count - 1
         Set Dest = Ows.Range("T:T").Find(Rng(1).Value, , , xlWhole, , , False, , False)
         If Dest Is Nothing Then
            Set Dest = Ows.Range("T" & Rows.Count).End(xlUp).Offset(1)
            Dest.Value = Rng(1).Value
         End If
         If Rng(j).Offset(, 11) <> "Nort short" Then
            Rng(j).Offset(, 1).Resize(, 5).Copy Dest.Offset(, i)
         End If
      Next j
   Next Rng
End Sub

Thanks a lot, it's working now.

 

[Fluff]

You're welcome & thanks for the feedback