The issue is that up to a certain point, each column is copied to the right, and then it suddenly starts going to the left, and ignoring a column.
I didn't write the thing, have as yet been unable to pick it apart to even attempt to solve it properly. I've fiddled with it, but haven't gotten any useful results to go off of.
For colx = 2 To maxColumns Step 2
ActiveSheet.Columns(colx).Insert
ActiveSheet.Columns(colx - 1).Interior.Color = RGB(255, 153, 0)
Next
maxRows = ActiveSheet.UsedRange.Rows.Count
maxColumns = ActiveSheet.UsedRange.Columns.Count * 2 + 1
For colx = 2 To maxColumns Step 2
For iRow = 1 To maxRows
WorksheetFunction.CountA (Columns(1))
'If there is a comment, paste the comment text into column D and delete the original comment.
ActiveSheet.Cells(iRow, colx).Value = Trim(ActiveSheet.Cells(iRow, colx - 1).Value)
Next iRow
Next
As you can see in the image below, Rental Amount and Deposit Amount have worked, though Deposit Amount has also happend in the column AL, which should have Rent Frequency. Similarly Column AT should have "PROPERTY TYPE" and AV should have "FURNISHED TYPE" and so on and so forth...
Replace your entire code with this:
Option Explicit
Sub Macro1()
Dim LCol As Long, LRow As Long, i as Long, j as Long
With ThisWorkbook.Worksheets("Sheet1")
LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A1", .Cells(LRow, LCol)).Interior.Color = RGB(255, 153, 0)
For i = 1 To (LCol*2 - 1) Step 2
.Columns(i+1).Insert
For j = 1 To LastRow
.Cells(j, i+1).Value = Trim(.Cells(j, i).Value)
Next j
Next i
End With
End Sub
Related
I have a spreadsheet that contains data starting in row 2 column 1 and has 42 columns. I am trying to write a VBA code that will search all rows of my data starting with row 2 and if the value in column 32 is greater than 575, I need the code to insert enough rows below that row so that whatever the value was (whether it be 600 or 2,000) can be split into increments of 575. So for example, if row 5 column 32's value is 800, i want the code to add a row below row 5, and i want it to autofill the new row with the value of 575 in column 32 and replace the value in the original row with whatever it was minus 575. Also, in the first column of my data I have dates. For each new row that is created, I want it to be a week earlier than the date in the original row. Here is an example of what my data looks like:
Column1 ...Column 32.......Column 42
8/15/2019 // 3873
Here is what i want it to look like after I run the code.
Column1 ...Column 32......Column 42
8/15/2019 // 423
8/8/2019 // 575
8/1/2019 // 575
7/25/2019 // 575
7/18/2019 // 575
7/11/2019 // 575
7/4/2019 // 575
The slash marks are just there to show the separation in columns. And I want the data from all the other columns to stay the same as the row above. Is there a good way to do this?
This is the code I've come up with so far. However, the problem with it is I can't seem to figure out how to program it so that it know how many rows to add based on how large the quantity is. As of now, it just adds a row below any row that the value of column 32 is greater than 575. Also, it just adds blank rows. I don't have anything in my code that says what values to put in the newly created rows
Sub BlankLine()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim LargeOrder As Integer
Col = "AF"
StartRow = 1
BlankRows = 1
LargeOrder = 575
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col).Value > LargeOrder Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
As I mentioned before, I need the code to add however many rows needed to accommodate the original quantity to be broken into increments of 575, and also subtract a week with every row created. Thank you in advance for your help.
There are numerous way to achieve the objective. One is instead of reverse loop, you go down inserting balance amount and again on next row recalculated and so on till blank is encounters. May try the code tested with makeshift data
Option Explicit
Sub addLine()
Dim Col As Variant
'Dim BlankRows As Long
'Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim LargeOrder As Integer
Dim Ws As Worksheet
Dim ActNum As Double, Balance As Double
Set Ws = ThisWorkbook.ActiveSheet
Col = "AF"
StartRow = 2
'BlankRows = 1
LargeOrder = 575
R = StartRow
With Ws
ActNum = .Cells(R, Col).Value
Do While ActNum <> 0
If ActNum > LargeOrder Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Range(.Cells(R, 1), .Cells(R, 42)).Copy Destination:=.Cells(R + 1, 1)
.Cells(R + 1, 1).Value = .Cells(R + 1, 1).Value - 7
'simpler calculation
Balance = IIf(ActNum Mod LargeOrder > 0, Int(ActNum / LargeOrder) * LargeOrder, ActNum - LargeOrder)
'Balance = IIf(ActNum Mod LargeOrder > 0, Int(ActNum / LargeOrder) * LargeOrder, Int(ActNum / LargeOrder) * LargeOrder - LargeOrder)
.Cells(R + 1, Col).Value = Balance
.Cells(R, Col).Value = ActNum - Balance
End If
R = R + 1
ActNum = .Cells(R, Col).Value
Loop
End With
End Sub
Edit: may try the modified code below for the variance in requirement
Option Explicit
Sub addLine2()
Dim Col As Variant
Dim LastRow As Long
Dim R As Long, i As Long
Dim StartRow As Long
Dim RowtoAdd As Long
Dim Ws As Worksheet
Dim ActNum As Double, Balance As Double
Set Ws = ThisWorkbook.ActiveSheet
Col = "AS"
StartRow = 2
LastRow = Ws.Cells(Rows.Count, Col).End(xlUp).Row
R = StartRow
With Ws
Do
RowtoAdd = .Cells(R, Col).Value
LastRow = LastRow + RowtoAdd
For i = 1 To RowtoAdd
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R, 1).EntireRow.Copy Destination:=.Cells(R + 1, 1)
.Cells(R + 1, 1).Value = .Cells(R + 1, 1).Value - 7
.Cells(R + 1, 32).Value = ""
R = R + 1
Next i
R = R + 1
Loop Until R > LastRow
End With
End Sub
For processing with other application I Need to prepare a Folder path.
The desired result is the green column. There should be a Formula doing something like "take a step to the Right - go upwards until you find a value" then put together with the value in yellow cell + do same with next column.
In Brief: a) Yellow is Achor b) orange columns B/C/D are user's entries c) green is desired result.
I had to do this once with an xml that I needed to represent as a flat file. If you copy those values down to fill blank cells, you could just have a column that concatenates each column to the left. But that's not very programmatic and a bit labor intensive.
Here's some VBA that will do what I explained above but automatically instead. Might be clunky but it works in my tests. It was easier to fill in the blanks than to go down and left and right and program all that if/then logic.
Turns this
Into this
Sub pathMaker()
Dim r As Integer
Dim c As Integer
Dim lrow As Integer
Dim lcol As Integer
Dim firstrow As Integer
Dim headers As String
Dim resultcol As Integer
lcol = ActiveSheet.UsedRange.Columns.Count
lrow = ActiveSheet.UsedRange.Rows.Count
resultcol = lcol + 1
headers = MsgBox("Does your data contain a header row?",
vbQuestion + vbYesNo, "Headers")
' Determines whether to make the first or second row a
'filepath
If headers = vbYes Then
firstrow = 2
'lrow = lrow - 1
Else
firstrow = 1
End If
'Goes through each row a column at a time and copies the
'filepath element down (which results
'in an extra row at the end, but it isn't included in the
'list of filepaths later so just ignore)
For c = 1 To lcol
Select Case c
Case 1
For r = firstrow To lrow
If IsEmpty(Cells(r, c).Offset(1, 0)) = True Then
Cells(r, c).Offset(1, 0) = Cells(r, c)
End If
Next r
Case Is > 1
For r = firstrow To lrow
If IsEmpty(Cells(r, c).Offset(1, 0)) = True Then
If Cells(r, c).Offset(1, -1) = Cells(r,
c).Offset(0, -1) Then
Cells(r, c).Offset(1, 0) = Cells(r, c)
End If
End If
Next r
End Select
Next c
'Concatenates populated cells into filepaths in the last
'column plus one
For ir = firstrow To lrow
For ic = 1 To lcol
If IsEmpty(Cells(ir, ic)) = False Then
Cells(ir, resultcol) = Cells(ir, resultcol) &
Cells(ir, ic) & "\"
End If
Next ic
Next ir
End Sub
Hope it helps! Good luck.
I have a lot of rows of data in Excel, each one corresponds to a product. So for example, my first row is "Lady's Black Dress" and then it has in another cell, sizes separated by commas and also colours in one cell too.
Title Size Colour Price Before Price After
Ladies Dress S,M,L,XL,XXL Blue, Black, Red 19.99 29.99
Men's Trousers S,M,L,XL,XXL Brown, Yellow, Orange 39.99 59.99
hj
So what I need is a VBA that creates a unique row (SKU, essentially) for each product variaton, so my data then looks like this:
I did ask this question before but only for 2 columns, a kind soul provided this VBA which does work, but I need the other columns. I don't quite understand how to adapt this VBA and was changing the letter "B" to "E" but this doesn't seem to work.
Option Explicit
Sub sizeExpansion()
Dim i As Long, szs As Variant
With Worksheets("sheet1")
For i = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1
szs = Split(.Cells(i, "B").Value2, ",")
If CBool(UBound(szs)) Then
.Cells(i, "A").Resize(UBound(szs), 1).EntireRow.Insert
.Cells(i, "A").Resize(UBound(szs) + 1, 1) = .Cells(UBound(szs) + i, "A").Value2
.Cells(i, "B").Resize(UBound(szs) + 1, 1) = Application.Transpose(szs)
End If
Next i
End With
End Sub
Try this modification with an additional split variant and some maths adjustment.
Option Explicit
Sub sizeAndColorExpansion()
Dim i As Long, s As Long, c As Long
Dim ttl As String, pb As Double, pa As Double
Dim szs As Variant, clr As Variant
With Worksheets("sheet1")
For i = .Cells(.Rows.Count, "E").End(xlUp).Row To 2 Step -1
ttl = .Cells(i, "A").Value2
pb = .Cells(i, "D").Value2
pa = .Cells(i, "E").Value2
szs = Split(.Cells(i, "B").Value2, ",")
clr = Split(.Cells(i, "C").Value2, ",")
If CBool(UBound(szs)) Or CBool(UBound(clr)) Then
.Cells(i, "A").Resize((UBound(szs) + 1) * (UBound(clr) + 1) - 1, 1).EntireRow.Insert
For s = 0 To UBound(szs)
For c = 0 To UBound(clr)
.Cells(i + (s * (UBound(clr) + 1)) + c, "A").Resize(1, 5) = _
Array(ttl, Trim(szs(s)), Trim(clr(c)), pb, pa)
Next c
Next s
End If
Next i
End With
End Sub
In Column A, I have the below values from 1 to 20.
1. NBC997
2. EVO463
3. EVO426
4. EVO420
5. EVO826
6. EVO820
7. EVO863
8. CRO001
9. BCA915
10. SBH121
11. KEN500
12. GAM201
13. GAM1011
14. GAM101
15. SPR577
16. SPR580
17. SPR579
18. SPR576
19. DON201
20. MOR101
My formula below should be looking at column A and deleting the entire row if the left 2 characters <> "EV".
Once it finds one iteration it stops and doesn't go to the next line.
Sub remove()
Dim i As Long
For i = 1 To 20
If Left(Cells(i, "A"), 2) <> "EV" Then
Cells(i, "A").EntireRow.Delete
Else
End If
Next i
End Sub
I would not use the delete entire row. I would move the data up one row and then clear the contents of the last row.
Sub remove()
Dim i As Long
Dim x As Long
Dim lastCol As Long
Dim lastRow As Long
Const dataColumn As Long = 1
Const SearchPhrase As String = "EV"
Const firstRow As Long = 1
lastCol = Cells(firstRow, Columns.Count).End(xlToLeft).Column
lastRow = Cells(Rows.Count, dataColumn).End(xlUp).Row
x = 0
For i = lastRow To firstRow Step -1
If Left(Cells(i, dataColumn), Len(SearchPhrase)) <> SearchPhrase Then
If i = lastRow Then
Range(Cells(lastRow, dataColumn), Cells(lastRow, lastCol)).ClearContents
Else
Range(Cells(i, dataColumn), Cells(lastRow - 1 - x, lastCol)).Value = _
Range(Cells(i + 1, dataColumn), Cells(lastRow - x, lastCol)).Value
Range(Cells(lastRow - x, dataColumn), Cells(lastRow - x, lastCol)).ClearContents
End If
x = x + 1
End If
Next i
End Sub
I am uploading a Tabular data into my SQL database.
The following is the original look of the data.
I want to take each temperature (Y axis) in a column and then each gravity (X Axis) in next Column, followed by the intersecting value.
Like This:
i got helped from a guy from ExcelForum. Here is the Macro Code, that solved my problem.
Option Explicit
Sub transpose_data()
Dim lrow As Long, lcol As Long, a As Long, i As Long, j As Long
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Output"
a = 1
With Worksheets("Original")
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
lcol = .Range("IV1").End(xlToLeft).Column
For i = 2 To lrow
For j = 2 To lcol
Worksheets("Output").Cells(a, 1).Value = .Cells(i, 1).Value
Worksheets("Output").Cells(a, 2).Value = .Cells(1, j).Value
Worksheets("Output").Cells(a, 3).Value = .Cells(i, j).Value
a = a + 1
Next j
Next i
End With
Worksheets("Output").Columns("A:C").NumberFormat = "0.00"
End Sub
Make sure to change the Sheet name to 'Original' in order to have this code working.