0

Am having difficulty enhancing my code to remove the "SELECT" option and use the ASSIGNMENT. Meaning to change from the SELECT, COPY and PASTE to the assigning Values Directly. Am an absolute beginner, if anyone could lead me through. My main issue is in the loop, however, here is the full code, any suggestion, recommendation is welcomed, just to make it more efficient!

Here is my code:

Sub LINK_ANALYSIS()

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False

Dim NumberOfColumns As Integer

Dim rng As Range


NumberOfColumns = ActiveSheet.UsedRange.Columns.Count

Sheets("Sheet2").Range("A1").Value2 = Sheets("Sheet1").Range("A1").Value2
Sheets("Sheet2").Range("A2:B2").Value2 = "SUBJECT"

Let x = 4

Do While x <= NumberOfColumns


ActiveSheet.UsedRange.AutoFilter Field:=x, Criteria1:="1", Criteria2:="2", Operator:=xlOr

ActiveSheet.UsedRange.Cells(2, x).Select

Set rng = Range(Cells(ActiveCell.Row + 1, ActiveCell.Column), Cells(Rows.Count, ActiveCell.Column))

rng.SpecialCells(xlCellTypeVisible).Cells(1).Select

If ActiveCell.Value >= "1" Then

       Cells(1, (x - 1)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Sheets("Sheet2").Select
        Range("A2").Select
        Selection.End(xlToRight).Select
        ActiveCell.Offset(0, 1).Select
        ActiveSheet.Paste
        Sheets("Sheet1").Select
        Application.CutCopyMode = False
        Range("A1").Select

End If

ActiveSheet.UsedRange.AutoFilter Field:=x

x = x + 2


Loop

Sheets("Sheet2").Select
ActiveSheet.Cells.EntireColumn.AutoFit
Range("A1").Select

Sheets("Sheet2").Copy

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
     
End Sub

The contention...

If ActiveCell.Value >= "1" Then
       
Sheets("Sheet2").Range("A2").Selection.End(xlToRight).ActiveCell.Offset(0, 1).Value2 = Cells(1, (x - 1)).Range(Selection, Selection.End(xlDown)).Value2
        


End If

I expected this assignment code to copy the selected cells in sheet1 and assign them to the selected cell in sheet2

The copy paste code works but, when i make attempt to use the assignment code it return error "out of range". I design the code to filter selected columns on certain criteria and copy the results from the leftcolmn and past to sheet2, the loop continues until the last column.

Solar Mike
  • 7,156
  • 4
  • 17
  • 32
Mahadi Mu'azu L G
  • 1
  • your `rng.SpecialCells(xlCellTypeVisible).Cells(1).Select` will activate the first visible row column x. I wonder, why you check `If ActiveCell.Value >= "1"` Isn't whatever row of the first visible row column x value will be surely 1 or 2 ? Anyway, after the filtering code ... `With ActiveSheet.UsedRange` ... `Set rg = Range(.Cells(2, x), .Cells(Rows.Count, x).End(xlUp)).SpecialCells(xlVisible)` ... `end with` --> this should create rg variable where the range is the visible row of column x of the used range. Continue.... – karma Dec 26 '22 at 10:28
  • If the column you want to copy is column x-1 of the used range, then `rg.offset(0,-1).copy Destination:=sheets("Sheet2").range("A2").end(xltoright).offset(0,1)` this will copy the rg.offset(0,-1) and paste to sheet "Sheet2" row 2 of the first column which is blank. – karma Dec 26 '22 at 10:30
  • Sometimes using the clipboard (copy/pasting) is easier, definitely with filtered ranges. Also, have a read about avoiding select : https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba?rq=1 – Notus_Panda Dec 26 '22 at 13:30
  • If you're sure about wanting to avoid using the clipboard, you can count the cells in your range and use that in a variable to resize so your range sizes match. Though (imo) this is more convoluted than a normal `.Copy destination:=` as Karma suggested. – Notus_Panda Dec 26 '22 at 13:35
  • Are there 2 header rows on sheet1 ? – CDP1802 Dec 26 '22 at 15:51
  • Corrected your title from ALL CAPS so you are not SHOUTING at us. – Solar Mike Dec 26 '22 at 21:43
  • the solution by Karma hits directly at my question and the requested suggestion was aptly provided, however, Notus_Panda has observed the need to avoid the clip board but has not suggested the code to replace mine. Thanks – Mahadi Mu'azu L G Dec 27 '22 at 20:01
  • I Have modified my code as per Karma Suggested, but the if function execute regardles of the condition fulfilled or not. I intended that if the filter criteria doesnot exist, on the filtered column, then no action of copy the values of the column before it, but in this case, the the header is copied. yet. in summaryWith ActiveSheet.UsedRange Set RG = Range(.Cells(2, x), .Cells(Rows.Count, x).End(xlUp)).SpecialCells(xlVisible) End With If ActiveCell.Value >= "1" Then RG.Offset(0, -1).Copy Destination:=Sheets("Sheet2").Range("A2").End(xlToRight).Offset(0, 1) – Mahadi Mu'azu L G Dec 27 '22 at 20:41

0 Answers0