I have a portfolio report I build from VBA code on monthly and ad-hoc basis. It works fine today, but the underlying VBA is far from optimized. The code sniplet below is repeated 5 times as there are 5 projects in the system now, but it will grow to 50 shortly. Is there anyone that have suggestions as to how I can utilize VBA more elegantly performing the copying to the locations specified in the code (see sniplet below)
Sub CreatePortFolio()
Application.ScreenUpdating = False
'Clears old data
Application.Goto Reference:="PFData" 'Named range in the portfolio overview sheet
Selection.ClearContents
'************* Project 1
If Not Sheets(Sheets.Count).Range("BG1").Value = "" Then
Ark4.Range("B5").Value = Sheets(Sheets.Count).Range("BG1").Value 'Ark4 is the portfolio report and the sheets.count is used to pick the latest import of data - always in the same format
Ark4.Range("C5").Value = Sheets(Sheets.Count).Range("BF1").Value
Ark4.Range("D5").Value = Sheets(Sheets.Count).Range("BH1").Value
Ark4.Range("E5").Value = Sheets(Sheets.Count).Range("AU1").Value
Ark4.Range("F5").Value = Sheets(Sheets.Count).Range("AU2").Value
Ark4.Range("G5").Value = Sheets(Sheets.Count).Range("AU3").Value
Ark4.Range("H5").Value = Sheets(Sheets.Count).Range("AV1").Value
Ark4.Range("I5").Value = Sheets(Sheets.Count).Range("AV2").Value
Ark4.Range("J5").Value = Sheets(Sheets.Count).Range("AV3").Value
Ark4.Range("L4").Value = Sheets(Sheets.Count).Range("AP3").Value
Ark4.Range("L5").Value = Sheets(Sheets.Count).Range("AP4").Value
Ark4.Range("L6").Value = Sheets(Sheets.Count).Range("AP5").Value
Ark4.Range("M4").Value = Sheets(Sheets.Count).Range("AQ3").Value
Ark4.Range("M5").Value = Sheets(Sheets.Count).Range("AQ4").Value
Ark4.Range("M6").Value = Sheets(Sheets.Count).Range("AQ5").Value
Ark4.Range("N4").Value = Sheets(Sheets.Count).Range("AR3").Value
Ark4.Range("N5").Value = Sheets(Sheets.Count).Range("AR4").Value
Ark4.Range("N6").Value = Sheets(Sheets.Count).Range("AR5").Value
Ark4.Range("O4").Value = Sheets(Sheets.Count).Range("AS3").Value
Ark4.Range("O5").Value = Sheets(Sheets.Count).Range("AS4").Value
Ark4.Range("O6").Value = Sheets(Sheets.Count).Range("AS5").Value
Ark4.Range("Q4").Value = Sheets(Sheets.Count).Range("AP10").Value
Ark4.Range("Q5").Value = Sheets(Sheets.Count).Range("AP11").Value
Ark4.Range("Q6").Value = Sheets(Sheets.Count).Range("AP12").Value
Ark4.Range("R4").Value = Sheets(Sheets.Count).Range("AQ10").Value
Ark4.Range("R5").Value = Sheets(Sheets.Count).Range("AQ11").Value
Ark4.Range("R6").Value = Sheets(Sheets.Count).Range("AQ12").Value
Ark4.Range("S4").Value = Sheets(Sheets.Count).Range("AR10").Value
Ark4.Range("S5").Value = Sheets(Sheets.Count).Range("AR11").Value
Ark4.Range("S6").Value = Sheets(Sheets.Count).Range("AR12").Value
Ark4.Range("T4").Value = Sheets(Sheets.Count).Range("AS10").Value
Ark4.Range("T5").Value = Sheets(Sheets.Count).Range("AS11").Value
Ark4.Range("T6").Value = Sheets(Sheets.Count).Range("AS12").Value
Ark4.Range("U5").Value = Sheets(Sheets.Count).Range("AW4").Value
Ark4.Range("V5").Value = Sheets(Sheets.Count).Range("AW3").Value
End If
'******* I Want to avoid copying the above code 50 times *******
Application.ScreenUpdating = True
End Sub
The Portfolio report look like this:
The data sheet to build the report from look like this:
Try,
Sub test()
Dim wsData As Worksheet
Dim Ws As Worksheet
Dim vDB As Variant
Dim vR() As Variant
Dim Ark4 As Worksheet
Dim i As Long, n As Long, r As Long
Set Ark4 = Sheets(1) ' set your sheets
Set wsData = Sheets(Sheets.Count)
With wsData
r = .Range("BG" & Rows.Count).End(xlUp).Row + 11
vDB = .Range("ap1", "bh" & r)
End With
For i = 1 To r Step 12
If vDB(i, 18) <> "" Then
n = n + 3
ReDim Preserve vR(1 To 21, 1 To n)
'Column b ~ j
vR(1, n - 2) = vDB(i, 18) 'bg1
vR(2, n - 2) = vDB(i, 17) 'bf1
vR(3, n - 2) = vDB(i, 19)
vR(4, n - 2) = vDB(i, 6)
vR(5, n - 2) = vDB(i + 1, 6)
vR(6, n - 2) = vDB(i + 2, 6)
vR(7, n - 2) = vDB(i, 7)
vR(8, n - 2) = vDB(i + 1, 7)
vR(9, n - 2) = vDB(i + 2, 7)
'Column k ~ o
vR(10, n - 2) = "Budget"
vR(10, n - 1) = "Installemnt"
vR(10, n) = "Deviation"
vR(11, n - 2) = vDB(i + 2, 1) 'ap3
vR(11, n - 1) = vDB(i + 3, 1) 'ap4
vR(11, n) = vDB(i + 4, 1) 'ap5
vR(12, n - 2) = vDB(i + 2, 2) 'aq3
vR(12, n - 1) = vDB(i + 3, 2) 'aq4
vR(12, n) = vDB(i + 4, 2) 'aq5
vR(13, n - 2) = vDB(i + 2, 3) 'ar3
vR(13, n - 1) = vDB(i + 3, 3) 'ar4
vR(13, n) = vDB(i + 4, 3) 'ar5
vR(14, n - 2) = vDB(i + 2, 4) 'as3
vR(14, n - 1) = vDB(i + 3, 4) 'as4
vR(14, n) = vDB(i + 4, 4) 'as5
'Column p ~ z
vR(15, n - 2) = "Budget"
vR(15, n - 1) = "Installemnt"
vR(15, n) = "Deviation"
vR(16, n - 2) = vDB(i + 9, 1) 'ap10
vR(16, n - 1) = vDB(i + 10, 1) 'ap11
vR(16, n) = vDB(i + 11, 1) 'ap12
vR(17, n - 2) = vDB(i + 9, 2) 'aq10
vR(17, n - 1) = vDB(i + 10, 2) 'aq11
vR(17, n) = vDB(i + 11, 2) 'aq12
vR(18, n - 2) = vDB(i + 9, 3) 'ar10
vR(18, n - 1) = vDB(i + 10, 3) 'ar11
vR(18, n) = vDB(i + 11, 3) 'ar12
vR(19, n - 2) = vDB(i + 9, 4) 'as10
vR(19, n - 1) = vDB(i + 10, 4) 'as11
vR(19, n) = vDB(i + 11, 4) 'as12
'Column u,v
vR(20, n - 2) = vDB(i + 3, 8) 'aw4
vR(21, n - 2) = vDB(i + 2, 8) 'aw3
End If
Next i
With Ark4
.Range("b4").Resize(n, 21) = WorksheetFunction.Transpose(vR)
End With
End Sub
It is assumed that the data in the data sheet is repeated as shown in the following figure.
Related
I have a dashboard and I would like to have a main sheet that summarize some name that I want to search for, so all my data are in other sheets.
I am trying to copy and past a table from data sheet to the main sheet. I´ve tried using =Vlookup and =xlookup, but it didn't wor. Now I am trying to use VBA.
First of all the data sheet is:
Data sheet
I would like to copy and past data from I3:M6 (data sheet) if what I am searching for is "name1" in main sheet. On the other hand, if I want to search for "name2" I need to copy I9:M12 (data sheet) and so on.
the table 2 on main sheet nee just the data from the data sheet:
main sheet
With that in mind, I´ve tried to create a VBA:
Sub table()
Dim i As Long, j as long
Dim wsMain As Worksheet, wsRV2 As Worksheet
Set wsMain = ThisWorkbook.Worksheets("main")
Set wsRV2 = ThisWorkbook.Worksheets("rv")
For i = 2 To 250 Step 6 'loop in increments of 15
For j = 9 To 10 Step 1
If wsRV2.Cells(i, 8) = wsMain.Cells(4, 3) Then
wsMain.Cells(12, 28) = wsRV2.Cells(i + 1, j)
wsMain.Cells(12, 29) = wsRV2.Cells(i + 1, j + 1)
wsMain.Cells(12, 30) = wsRV2.Cells(i + 1, j + 2)
wsMain.Cells(12, 31) = wsRV2.Cells(i + 1, j + 3)
wsMain.Cells(12, 32) = wsRV2.Cells(i + 1, j + 4)
wsMain.Cells(13, 28) = wsRV2.Cells(i + 2, j)
wsMain.Cells(13, 29) = wsRV2.Cells(i + 2, j + 1)
wsMain.Cells(13, 30) = wsRV2.Cells(i + 2, j + 2)
wsMain.Cells(13, 31) = wsRV2.Cells(i + 2, j + 3)
wsMain.Cells(13, 32) = wsRV2.Cells(i + 2, j + 4)
wsMain.Cells(14, 28) = wsRV2.Cells(i + 3, j)
wsMain.Cells(14, 29) = wsRV2.Cells(i + 3, j + 1)
wsMain.Cells(14, 30) = wsRV2.Cells(i + 3, j + 2)
wsMain.Cells(14, 31) = wsRV2.Cells(i + 3, j + 3)
wsMain.Cells(14, 32) = wsRV2.Cells(i + 3, j + 4)
wsMain.Cells(15, 28) = wsRV2.Cells(i + 4, j)
wsMain.Cells(15, 29) = wsRV2.Cells(i + 4, j + 1)
wsMain.Cells(15, 30) = wsRV2.Cells(i + 4, j + 2)
wsMain.Cells(15, 31) = wsRV2.Cells(i + 4, j + 3)
wsMain.Cells(15, 32) = wsRV2.Cells(i + 4, j + 4)
End If
Next j
Next i
end sub
i = line and j = column
If wsRV2.Cells(i, 8) = wsMain.Cells(4, 3) Then -->> if name1, name 2 ... is the same for both sheets
I know it is not the best way to do it by far (and it is not working). What am I doing wrong? If there´s a way to do it using excel function instead using vba I would like to know as well. I accept both solutions. Thank you so muchhh!
I would like to know if it would be possible to use the IFERROR, INDEX, MATCH function on below scenario.
D2:=INDEX($A$2:$A$16, MATCH(0, COUNTIF($D$1:$D1, $A$2:$A$16), 0))
E2: =IFERROR(INDEX($B$2:$B$16, MATCH(0, COUNTIF($D2:D2,$B$2:$B$16)+IF($A$2:$A$16<>$D2, 1, 0), 0)), "")
H2: =IFERROR(INDEX($C$2:$C$16, MATCH(0, COUNTIF($D2:D2,$C$2:$C$16)+IF($A$2:$A$16<>$D2, 1, 0), 0)), "")
I2: =IFERROR(INDEX($C$2:$C$16, MATCH(0, COUNTIF($D2:H2,$C$2:$C$16)+IF($A$2:$A$16<>$D2, 1, 0), 0)), "")
Based on the data of Countries and Cities filled in yellow on the left, by using the IFERROR, INDEX, MATCH formula I managed to get all the data I need. Now if there are more than 3 City, I want for the excel to continue the list of cities by creating another row under it as example of row filled in red.
I hope it makes sence. Let me know if it's possible.
You did tag vba as well as excel-formula so give this a try
Sub condense()
Dim src, dest(), ws As Worksheet, srcRange As Range, i As Long, j As Long, countryCount As Long, rowNum As Long
Set ws = ActiveSheet
Set srcRange = ws.Cells(1, 1).Resize(ws.Cells(ws.Rows.Count, 1).End(xlUp).Row, 3)
src = srcRange.Value2
ReDim dest(1 To UBound(src, 1) - 1, 1 To 7)
rowNum = 1
i = 2
Do While i <= UBound(src, 1)
countryCount = Application.CountIf(srcRange.Columns(1), src(i, 1))
For j = 1 To countryCount
dest(rowNum + Int((j - 1) / 3), 1) = src(i + j - 1, 1)
dest(rowNum + Int((j - 1) / 3), 2 + ((j - 1) Mod 3)) = src(i + j - 1, 2)
dest(rowNum + Int((j - 1) / 3), 5 + ((j - 1) Mod 3)) = src(i + j - 1, 3)
Next j
i = i + countryCount
rowNum = rowNum + 1 + Int((countryCount - 1) / 3)
Loop
ws.Cells(2, 4).Resize(rowNum, 7).Value2 = dest
With ws.Cells(1, 4).Resize(1, 7)
.Value2 = Strings.Split("Country,City1,City2,City3,Image1,Image2,Image3", ",")
.EntireColumn.AutoFit
End With
End Sub
EDIT 17-Jul-2022 (per comment from OP)
Sub condenseInto4cols()
Dim src, dest(), ws As Worksheet, srcRange As Range, i As Long, j As Long, countryCount As Long, rowNum As Long
Set ws = ActiveSheet
Set srcRange = ws.Cells(1, 1).Resize(ws.Cells(ws.Rows.Count, 1).End(xlUp).Row, 3)
srcRange.Sort key1:=ws.Cells(2, 1), order1:=xlAscending, Header:=xlYes
src = srcRange.Value2
ReDim dest(1 To UBound(src, 1) - 1, 1 To 9)
rowNum = 1
i = 2
Do While i <= UBound(src, 1)
countryCount = Application.CountIf(srcRange.Columns(1), src(i, 1))
For j = 1 To countryCount
dest(rowNum + Int((j - 1) / 4), 1) = src(i + j - 1, 1)
dest(rowNum + Int((j - 1) / 4), 2 + ((j - 1) Mod 4)) = src(i + j - 1, 2)
dest(rowNum + Int((j - 1) / 4), 6 + ((j - 1) Mod 4)) = src(i + j - 1, 3)
Next j
i = i + countryCount
rowNum = rowNum + 1 + Int((countryCount - 1) / 4)
Loop
ws.Cells(2, 4).Resize(rowNum, 9).Value2 = dest
With ws.Cells(1, 4).Resize(1, 9)
.Value2 = Strings.Split("Country,City1,City2,City3,City4,Image1,Image2,Image3,Image4", ",")
.EntireColumn.AutoFit
End With
srcRange.Sort key1:=ws.Cells(2, 2), order1:=xlAscending, Header:=xlYes
End Sub
I'm trying to get my VBA code to output a graph in excel based on an inputted range that was selected using a user defined function from multiple cells. I've passed the data to the sub as a range but it ends up assuming that the range is two data sets rather than one data set with x and y values. The data set is selected from excel into a function that is being written separately which then calls the sub.
Sub CreateChart(ByRef r As Range)
Dim cht As Object
Set cht = ActiveSheet.Shapes.AddChart2
cht.Chart.SetSourceData Source:=r
cht.Chart.ChartType = xlXYScatterLines
End Sub
I called the sub through
Call CreateChart(r)
with r being a two column range of data that was selected from excel.
Public Function cubic(ByVal r As Range, x As Double, Optional check As Integer = 1) As Double
The overall function code is here as well
Public Function cubic(ByVal r As Range, x As Double, Optional check As Integer = 1) As Double
Dim data() As Double
Dim check1 As Integer
Dim Smatrix() As Double
Dim Tmatrix() As Double
Dim Xmatrix() As Double
Dim Amatrix() As Double
Dim Hmatrix() As Double
Dim m As Integer
Dim i As Integer
m = r.Rows.Count
ReDim data(1 To m, 2)
ReDim Smatrix(1 To m, 1 To m)
ReDim Tmatrix(1 To m, 4)
ReDim Xmatrix(1 To m)
ReDim Amatrix(1 To m - 1, 1 To 4)
ReDim Hmatrix(1 To m)
check1 = Test(check)
For i = 1 To m
data(i, 1) = r(i, 1).Value
data(i, 2) = r(i, 2).Value
Next i
Smatrix(1, 1) = 1
Smatrix(m, m) = 1
For i = 1 To m - 1
Hmatrix(i) = data(i + 1, 1) - data(i, 1)
Next i
If check1 = 2 Then
Smatrix(1, 2) = -1
Smatrix(m, m - 1) = -1
End If
For i = 2 To m - 1
Smatrix(i, i - 1) = Hmatrix(i - 1)
Smatrix(i, i + 1) = Hmatrix(i)
Smatrix(i, i) = 2 * (Hmatrix(i - 1) + Hmatrix(i))
Next i
For i = 2 To m - 1
Tmatrix(i, 4) = 6 * ((data(i + 1, 2) - data(i, 2)) / Hmatrix(i) - (data(i, 2) - data(i - 1, 2)) / Hmatrix(i - 1))
Next i
For i = 1 To m
If i <> 1 Then
Tmatrix(i, 1) = Smatrix(i, i - 1)
End If
Tmatrix(i, 2) = Smatrix(i, i)
If i <> m Then
Tmatrix(i, 3) = Smatrix(i, i + 1)
End If
Next i
For i = 2 To m
Tmatrix(i, 1) = Tmatrix(i, 1) / Tmatrix(i - 1, 2)
Tmatrix(i, 2) = Tmatrix(i, 2) - Tmatrix(i, 1) * Tmatrix(i - 1, 3)
Tmatrix(i, 4) = Tmatrix(i, 4) - Tmatrix(i, 1) * Tmatrix(i - 1, 4)
Next i
Xmatrix(m) = Tmatrix(m, 4) / Tmatrix(m, 2)
For i = m - 1 To 1 Step -1
Xmatrix(i) = (Tmatrix(i, 4) - Tmatrix(i, 3) * Xmatrix(i + 1)) / Tmatrix(i, 2)
Next i
For i = 1 To m - 1
Amatrix(i, 1) = (Xmatrix(i + 1) - Xmatrix(i)) / 6 * Hmatrix(i)
Amatrix(i, 2) = Xmatrix(i) / 2
Amatrix(i, 3) = (data(i + 1, 2) - data(i, 2)) / Hmatrix(i) - Hmatrix(i) * Xmatrix(i) / 2 - Hmatrix(i) * (Xmatrix(i + 1) - Xmatrix(i)) / 6
Amatrix(i, 4) = data(i, 2)
Next i
If x < data(1, 1) Or x > data(m, 1) Then
Call Check2(x)
If x < data(1, 1) Then
cubic = Amatrix(1, 1) * (x - data(1, 1)) ^ 3 + Amatrix(1, 2) * (x - data(1, 1)) ^ 2 + Amatrix(1, 3) * (x - data(1, 1)) + Amatrix(1, 4)
ElseIf x > data(m, 1) Then
cubic = Amatrix(m - 1, 1) * (x - data(m - 1, 1)) ^ 3 + Amatrix(m - 1, 2) * (x - data(m - 1, 1)) ^ 2 + Amatrix(m - 1, 3) * (x - data(m - 1, 1)) + Amatrix(m - 1, 4)
End If
ElseIf x = data(m, 1) Then
cubic = data(m, 2)
Else
For i = 1 To m - 1
If data(i, 1) < x And x < data(i + 1, 1) Then
cubic = Amatrix(i, 1) * (x - data(i, 1)) ^ 3 + Amatrix(i, 2) * (x - data(i, 1)) ^ 2 + Amatrix(i, 3) * (x - data(i, 1)) + Amatrix(i, 4)
ElseIf x = data(i, 1) Then
cubic = data(i, 2)
End If
Next i
End If
Call CreateChart(r)
End Function
As well as the subroutine and function called within the function that haven't been posted
Public Function Test(check As Integer) As Integer
Dim Response As Integer
If check = 1 Then
Response = MsgBox("Boundary Condition 1 selected, is this correct (select No for boundary condition 2)?", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 1
Else
Test = 2
End If
ElseIf check = 2 Then
Response = MsgBox("Boundary Condition 2 selected, is this correct (select No for boundary condition 1)?", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 2
Else
Test = 1
End If
Else
Response = MsgBox("Incorrect Boundary Condition, select Yes for condition 1 and No for condition 2", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 1
Else
Test = 2
End If
End If
End Function
Public Sub Check2(x)
MsgBox ("Value given is outside data range, answer may not be correct, extrapolating from calculated polynomial")
End Sub
Try
Sub CreateChart(ByRef r As Range)
Dim cht As Object
Set cht = ActiveSheet.Shapes.AddChart2(XlChartType:=xlXYScatterSmooth)
cht.Chart.SetSourceData Source:=r
End Sub
I have a working code that loops through the rows of an array then store the values into another array. No problem at the code in fact but I am trying to improve my skills and learn new skills
This is the code
Sub Test()
Dim a, i As Long, j As Long, n As Long
a = Cells(1).CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * UBound(a, 2))
For i = LBound(a) To UBound(a)
If i Mod 2 = 1 Then
For j = LBound(a, 2) To UBound(a, 2)
n = n + 1
If a(i, j) <> Empty Then b(n) = a(i, j)
Next j
Else
For j = UBound(a, 2) To LBound(a, 2) Step -1
n = n + 1
If a(i, j) <> Empty Then b(n) = a(i, j)
Next j
End If
Next i
Range("M2").Resize(n).Value = Application.Transpose(b)
End Sub
What I am trying to do is to compact the nested loop and this is my try
For j = iif(i mod2=1,LBound(a, 2) To UBound(a, 2),UBound(a, 2) To LBound(a, 2) Step -1)
But this seems not to ne valid. Any ideas?
This works well and I can figure it out with the help of the experts
Thanks a lot for everyone
Sub Test()
Dim a, i As Long, j As Long, n As Long
a = Cells(1).CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * UBound(a, 2))
For i = LBound(a) To UBound(a)
For j = IIf(i Mod 2 = 1, LBound(a, 2), UBound(a, 2)) To IIf(i Mod 2 = 1, UBound(a, 2), LBound(a, 2)) Step IIf(i Mod 2 = 1, 1, -1)
n = n + 1
If a(i, j) <> Empty Then b(n) = a(i, j)
Next j
Next i
Range("N2").Resize(n).Value = Application.Transpose(b)
End Sub
Compacting Code
Option Explicit
Sub Test()
Dim a: a = Cells(1).CurrentRegion.Value
Dim ub1 As Long, ub2 As Long: ub1 = UBound(a): ub2 = UBound(a, 2)
ReDim b(1 To ub1 * ub2)
Dim i As Long, j As Long, n As Long, md As Long
For i = 1 To ub1
md = i Mod 2
For j = Abs(md - 1) * ub2 + md To md * ub2 + Abs(md - 1) _
Step 2 * (md - 1) + 1
n = n + 1
If a(i, j) <> Empty Then b(n) = a(i, j)
Next j
Next i
Range("M2").Resize(n).Value = Application.Transpose(b)
End Sub
I need help writing a VBA code to find duplicate values in one column and then merge cells based off that search.
E.g:
France 6216 EDE 009789 Company A
France 6216 EDF 009790 Company A
France 6216 EDG 009791 Company A
Germany 6216 EDH 009792 Company B
Becomes:
France 6216 EDE EDF EDG 009789 009790 009791 Company A
Germany 6216 EDH 009792 Company B
Its on a large spreadsheet where some dupes will have two but some could be as many as eight.
Can anyone help me?
Any questions please let me know.
Thanks so much!
Try out this macro,
Sub removeDupes()
Dim i As Long, j As Long, k As Long
Columns("A:E").Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlYes
Sheets.Add.Name = "newSheet"
Sheets("newSheet").Cells(1, 1) = Cells(2, 1)
Sheets("newSheet").Cells(1, 2) = Cells(2, 2)
Sheets("newSheet").Cells(1, 3) = Cells(2, 3)
Sheets("newSheet").Cells(1, 150) = Cells(2, 4)
Sheets("newSheet").Cells(1, 255) = Cells(2, 5)
j = 1
k = 1
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i + 1, 1) = Cells(i, 1) Then
Sheets("newSheet").Cells(j, 3 + k) = Cells(i + 1, 3)
Sheets("newSheet").Cells(j, 150 + k) = Cells(i + 1, 4)
k = k + 1
Else
j = j + 1
Sheets("newSheet").Cells(j, 1) = Cells(i + 1, 1)
Sheets("newSheet").Cells(j, 2) = Cells(i + 1, 2)
Sheets("newSheet").Cells(j, 3) = Cells(i + 1, 3)
Sheets("newSheet").Cells(j, 150) = Cells(i + 1, 4)
Sheets("newSheet").Cells(j, 255) = Cells(i + 1, 5)
k = 1
End If
Next i
For i = 255 To 1 Step -1
If Sheets("newSheet").Cells(1, i) = "" Then
Sheets("newSheet").Columns(i).Delete
End If
Next i
End Sub
Source:
Output: