vba to insert 3 empty cells in before column A in every 2nd row.

[andymalan]

my dear learned friends
I have searched Everywhere I can think of and cannot find a solution to this problem.
the closest I have gotten is the following code but its very slow and cuts the data and pastes it to col D.

Here s the code <
Dim X As Long

Range("A3").Select
For X = 3 To Cells(Rows.Count, "A").End(xlUp).Row Step 2
Cells(X, "A").Cut Cells(X - 0, "D")
Next
Columns("E:G").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("E1:G1").Select
Selection.Delete Shift:=xlToLeft

' Application.Goto Reference:="BuyOuts"
ActiveWorkbook.Worksheets("Cabinets").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Cabinets").Sort.SortFields.Add2 Key:=Range( _
"AK2:AK1000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Cabinets").Sort
.SetRange Range("AK1:BB1000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply

End With>

Your help will be much appreciated by my ignorant self.

 

[Takae]

I just changed For Next statement. Hope this helps.

Dim x, LR As Long, i As Long
Dim ws As Worksheet

Set ws = Sheets("Cabinets")
With ws
    LR = .Cells(Rows.Count, "A").End(xlUp).Row
    x = .Range(.Range("A3"), .Cells(LR, 4))
    For i = 1 To UBound(x) Step 2
        x(i, 4) = x(i, 1)
        x(i, 1) = ""
    Next
     .Range(.Range("A3"), .Cells(LR, 4)) = x
     
    .Columns("E:G").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    .Range("E1:G1").Delete Shift:=xlToLeft

    'Application.Goto Reference:="BuyOuts"
    With .Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("AK1")
        .SetRange ws.Range("AK1:BB1000")
'        .Header = xlYes
'        .MatchCase = False
'        .Orientation = xlTopToBottom
'        .SortMethod = xlPinYin
        .Apply
    End With
End With

 

[andymalan]

I just changed For Next statement. Hope this helps.

Dim x, LR As Long, i As Long
Dim ws As Worksheet

Set ws = Sheets("Cabinets")
With ws
    LR = .Cells(Rows.Count, "A").End(xlUp).Row
    x = .Range(.Range("A3"), .Cells(LR, 4))
    For i = 1 To UBound(x) Step 2
        x(i, 4) = x(i, 1)
        x(i, 1) = ""
    Next
     .Range(.Range("A3"), .Cells(LR, 4)) = x
    
    .Columns("E:G").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    .Range("E1:G1").Delete Shift:=xlToLeft

    'Application.Goto Reference:="BuyOuts"
    With .Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("AK1")
        .SetRange ws.Range("AK1:BB1000")
'        .Header = xlYes
'        .MatchCase = False
'        .Orientation = xlTopToBottom
'        .SortMethod = xlPinYin
        .Apply
    End With
End With

Dear Takae,
thank you for your super fast code. but it is still not inserting 3 cells in each row. maybe I explained what I need poorly, so let me try again.
Starting at r3, select from col A to Col BB and move the selection 3 cells to the right.
Do the same for every 2nd row.

Much appreciation
Andy

 

[Takae]

Hi andymalan,
I'm sorry, but I don't understand yet.
If you move the entire row to the right by three cells every two rows, the "Study" in E3 supposed to be H3. Looking at the second snapshot, only column A has moved to column D. Your code said too.

Please test below code.

LR = .Cells(Rows.Count, "A").End(xlUp).Row
 x = .Range(.Range("A3"), .Cells(LR, 57))
 For i = 1 To UBound(x) Step 2
       For j = 54 To 1 Step -1
            x(i, j + 3) = x(i, j)
        Next
        For j = 1 To 3
            x(i, j) = ""
        Next
    Next
    .Range(.Range("A3"), .Cells(LR, 57)) = x

 

[andymalan]

Dear Takae, that works so well and so fast, exactly what I needed.


thank you so much

 

[andymalan]

Dear Takae, please help me with the problem below;
I am working in 2 workbooks, "configExcalDat.xlsm" and "01SheetMaterial.xlsx".
In worksheets("Costing") of "configExcalDat.xlsm" I need to look at the text in the Range("B9:B17"). Match the text in B9:B17 with text found in workbook "01SheetMaterial.xlsx" Column A.
when the match is found, copy Col B and paste it to "configExcalDat.xlsm" Col A, copy Col G and paste it to "configExcalDat.xlsm"and Col D. repeat for B:10 to B:17.

Your assistance will be greatly appreciated.
warm regards
andymalan












your assistance will be greatly appreciated.

 

[Takae]

You can use xlookup formula if your version 2016.

 

[Takae]

ConfigExcalDat.xlsm A9 =xlookup(B9,[01SheetMaterial.xlsx]Sheet1!$A:$A,01SheetMaterial.xlsx]Sheet1!$B:$B,,0)
ConfigExcalDat.xlsm D9 =xlookup(B9,[01SheetMaterial.xlsx]Sheet1!$A:$A,[01SheetMaterial.xlsx]Sheet1!$G:$G,,0)