VBA- search sheet name from range.. then copy from range sheet, paste transpose into that sheetname

[xxsimixx]

Hello, I need some expert help please .... I have below Macro code.. It only looks for CDH.. I want it to find sheetname from range r2:r19 in sheet 'instructions' .. Copy that active cell row T:AE and transpose pastevalue into found sheet (CDH in this case) in range 'D4:D15'

Sub PasteBudgetDELETE()


    Sheets("instructions").Select
    Columns("R2:R19").Select
On Error Resume Next
Selection.Find(What:="CDH", After:=ActiveCell, LookIn:= _
    xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
    xlNext, MatchCase:=False, SearchFormat:=False).Activate
'If Err.Number = 91 Then
 '   MsgBox "ERROR: 'CDH' could not be found."
  '  End
'End If


Dim intRow As Integer
intRow = ActiveCell.Row
range("T" & intRow & ":AE" & intRow).Copy


    Sheets("CDH").Select
    range("D4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    
        End Sub

any help would be greatly appreciated.

 

[L. Howard]

Not sure I have the sheet/s layout correct, but you can give this a try.
The MyArr is the names of the sheets in your workbook and are also listed on Instructions sheet in column R, R2 and on down. You will replace the phony names I have in the array with your sheet names. Add or subtract the individual names to match the number required, keeping the format the same.

Copy to a standard module and run from sheet "Instructions".

Howard

Option Explicit

Sub XXSIMIXX_Copy()
Dim i As Long
Dim MyArr As Variant
Dim ir As Long
Dim rngCopy As Range, aRow As Range

MyArr = Array("ABC", "DEF", "GHI", "JKL", "POI", _
                     "Sheet6", "HTY", "DVB", "AXZ", "SDF", _
                     "KMN", "JHB", "CVB", "HUM", "DOM")
              
               
Application.ScreenUpdating = False

For i = LBound(MyArr) To UBound(MyArr)

   Set aRow = Range("R2", Cells(Rows.Count, "R").End(xlUp)).Find(What:=MyArr(i), _
                                                               LookIn:=xlValues, _
                                                               LookAt:=xlWhole, _
                                                               SearchOrder:=xlByRows, _
                                                               SearchDirection:=xlNext, _
                                                               MatchCase:=False)
                                               
  If Not aRow Is Nothing Then

    ir = aRow.Row
   
    With Sheets(MyArr(i))
      
      Set rngCopy = .Range("T" & ir & ":AE" & ir)
         
         If Sheets("Instructions").Range("D4") = "" Then
         
             rngCopy.Copy Sheets("Instructions").Range("D4")
 
           Else
 
             rngCopy.Copy Sheets("Instructions").Range("D" & Rows.Count).End(xlUp)(2)
             
         End If

   End With
  
  End If
 
Next 'I

Application.ScreenUpdating = True
End Sub

 

[xxsimixx]

Not sure I have the sheet/s layout correct, but you can give this a try.
The MyArr is the names of the sheets in your workbook and are also listed on Instructions sheet in column R, R2 and on down. You will replace the phony names I have in the array with your sheet names. Add or subtract the individual names to match the number required, keeping the format the same.

Copy to a standard module and run from sheet "Instructions".

Howard

Option Explicit

Sub XXSIMIXX_Copy()
Dim i As Long
Dim MyArr As Variant
Dim ir As Long
Dim rngCopy As Range, aRow As Range

MyArr = Array("ABC", "DEF", "GHI", "JKL", "POI", _
                     "Sheet6", "HTY", "DVB", "AXZ", "SDF", _
                     "KMN", "JHB", "CVB", "HUM", "DOM")
              
               
Application.ScreenUpdating = False

For i = LBound(MyArr) To UBound(MyArr)

   Set aRow = Range("R2", Cells(Rows.Count, "R").End(xlUp)).Find(What:=MyArr(i), _
                                                               LookIn:=xlValues, _
                                                               LookAt:=xlWhole, _
                                                               SearchOrder:=xlByRows, _
                                                               SearchDirection:=xlNext, _
                                                               MatchCase:=False)
                                               
  If Not aRow Is Nothing Then

    ir = aRow.Row
   
    With Sheets(MyArr(i))
      
      Set rngCopy = .Range("T" & ir & ":AE" & ir)
         
         If Sheets("Instructions").Range("D4") = "" Then
         
             rngCopy.Copy Sheets("Instructions").Range("D4")
 
           Else
 
             rngCopy.Copy Sheets("Instructions").Range("D" & Rows.Count).End(xlUp)(2)
             
         End If

   End With
  
  End If
 
Next 'I

Application.ScreenUpdating = True
End Sub

Howard.. thank you for your help. I don't think the layout is correct. I am unable to post anything.. So sheet instructions has a list in range r2:r19... need to find matching sheetname for each cell in that list.. then copy row t:ad of resp cell and paste in found sheetname transpose d4:d15

 

[Fluff]

Hi
Does this do what you're after

Sub PasteBudgetDELETE()

    Dim Fnd As Range
    Dim InstSht As Worksheet
    Dim Ws As Worksheet
    Dim Cl As Range

Application.ScreenUpdating = False

    Set InstSht = Sheets("instructions")
    
    With creatobject("scripting.dictionary")
        For Each Ws In Worksheets
            .Add Ws.Name, Nothing
        Next Ws
        For Each Cl In InstSht.Range("R2:R19")
            If .exists(Cl.Value) Then
                InstSht.Range("T" & Cl.Row, "AE" & Cl.Row).Copy
                Sheets(Cl.Value).Range("D4").PasteSpecial _
                    Paste:=xlPasteValues, Operation:=xlNone, _
                    SkipBlanks:=False, Transpose:=True
            End If
        Next Cl
    End With
    
Application.CutCopyMode = False
    
End Sub