I'm definitely a beginner when it comes to VBA beyond editing other peoples Macros. I have a project I'm working on where I need to combine data taken from the first pivot row and column headers and paste it in a new worksheet.
I need to take the row values in column A (which can be variable in data and count) multiply each row by the number of columns (also can be variable in data and count) such that if I have 3 columns (A,B,C) and two rows(1,2) before the macro after I will have 6 rows and 3 columns with the first 3 rows all having the same data as the original row 1 and the second 3 rows with the same data as the original row 2.
Then I have to paste down the columns to match the rows as well as the data to match the row and columns.
Original Pivot:
Goal After Macro:
I know I need to count the number of columns declare that a variable and then use that variable to copy the rows over to the new worksheet using a loop. I don't believe using a second pivot will work as it wont use the column header a cell value even if I do a tabular view. I've tried writing some code but I cant get to it as I'm on my home computer.
Any advise on how to get past the first part of having it count the number of columns and expand the rows would be much appreciated.
Here you go. This should do what you are looking for. You will just need to set the value of Sheet2("A1") manually to Accnt..
TESTED:
Private Sub FormShift()
Dim tRow As Long 'target Row
Dim lastCol As Long
Dim lastRow As Long
lastCol = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
tRow = 2
For iRow = 2 To lastRow
For iCol = 2 To lastCol
Sheets("Sheet2").Cells(tRow, 1) = Sheets("Sheet1").Cells(iRow, 1)
Sheets("Sheet2").Cells(tRow, 2) = Sheets("Sheet1").Cells(1, iCol)
Sheets("Sheet2").Cells(tRow, 3) = Sheets("Sheet1").Cells(iRow, iCol)
tRow = tRow + 1
Next iCol
Next iRow
End Sub
Sub horz_vert()
noOfColumns = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column - 1
noOfRows = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row - 1
Worksheets("Sheet2").Cells(1, 1) = Worksheets("Sheet1").Cells(1, 1)
For j = 1 To noOfRows
For I = 1 To noOfColumns
Worksheets("Sheet2").Cells((I + 1) + (j - 1) * noOfColumns, 1) = Worksheets("Sheet1").Cells(j + 1, 1)
Worksheets("Sheet2").Cells((I + 1) + (j - 1) * noOfColumns, 2) = Worksheets("Sheet1").Cells(1, I + 1)
Worksheets("Sheet2").Cells((I + 1) + (j - 1) * noOfColumns, 3) = Worksheets("Sheet1").Cells(j + 1, I + 1)
Next
Next
End Sub
Related
I am trying to copy row heights from one sheet1 to sheet2. but the following code is not working. note that the tables on both sheets are on different row numbers as well.
Call Unhide
With Sheet1
Dim LastRowC23 As Integer
LastRowC23 = Application.WorksheetFunction.Match("CYCLE 1",
.Range("A:A"), 0) - 1
Dim LastRow As Integer
LastRow = .Cells(.Rows.count, "B").End(xlUp).Row
.Range("A3:BD3"), 0)
Dim C1StartCol As Integer
C1StartCol = Application.WorksheetFunction.Match("CYCLE 1",
.Range("A1:BD1"), 0)
Dim C2StartCol As Integer
C2StartCol = Application.WorksheetFunction.Match("CYCLE 2", .Range("A1:BD1"), 0)
Dim LastCol As Integer
LastCol = .Cells(3, .Columns.count).End(xlToLeft).Column
Sheet2.Range("A1:CZ200").Clear
.Range("A1", .Cells(3, C2StartCol - 1)).Copy
Sheet2.Range("A1").PasteSpecial xlPasteAllUsingSourceTheme
Sheet2.Range("A1").PasteSpecial xlPasteColumnWidths
.Range(.Cells(LastRowC23 + 1, 1), .Cells(LastRow - 1, C2StartCol - 1)).Copy
Sheet2.Range("A4").PasteSpecial xlPasteAllUsingSourceTheme
Sheet2.Range("A4").PasteSpecial xlPasteColumnWidths
Dim i As Integer
Dim count As Integer
count = 4
For i = LastRowC23 + 1 To LastRow
.Rows(count).RowHeight = Sheet2.Rows(i).RowHeight
count = count + 1
Next i
Sheet2.Outline.ShowLevels ColumnLevels:=1
End With
The following is the part specific to row heights. Here, I am going through each row in the sheet 1 portion and making the sheet 2 row heights equal to the sheet 1 row heights.
Dim i As Integer
Dim count As Integer
count = 4
For i = LastRowC23 + 1 To LastRow
.Rows(count).RowHeight = Sheet2.Rows(i).RowHeight
count = count + 1
Next i
You are inside a With ... End With block that references sheet1 as the parent worksheet. LastRowC23 and LastRow are defined by row locations on sheet1. Count is arbitrarily assigned a value of 4.
If you are 'making the sheet 2 row heights equal to the sheet 1 row heights', then you seem to be using everything backwards.
For i = LastRowC23 + 1 To LastRow
Sheet2.Rows(count).RowHeight = .Rows(i).RowHeight
count = count + 1
Next i
In an Excel File, I need to find out the last 3 columns since because my column length gets updated each month when new data comes and need to do a sum on that last 3 columns values as I want recent data and put the sum in the new column.
EG:
A B C D
1 2 3 4
5 6 7 8
1 2 3 2
In the existing sheet, I want to find B, C, D as recent 3 columns (last 3 columns) and sum it up and put in new column E.
A B C D E
1 2 3 4 9
5 6 7 8 21
1 2 3 2 7
Please help me with ways to automate it with Excel macros. Thanks in advance for your help. I created a code but it's not working
Dim LastCol As Integer
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).column
End With
MsgBox LastCol
Dim LastRow As Integer
With ActiveSheet
LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row
End With
MsgBox LastRow
Dim j As Integer
For i = 2 To LastRow
For j = LastCol - 2 To LastCol
Range(i & LastCol + 1).Value = Range(i & j).Value + Range(i & j + 1).Value + Range(i & j + 2).Value
Next j
Next i
Put this formula in E1
=SUM(OFFSET(E1,0,-3,1,3))
to get the sum of the 3 columns before column E.
Any time you insert new columns before E it will adjust automatically to the last 3 columns right before the sum column.
For more information have a look at OFFSET function.
Use Arrays , Whenever you have to work with multiple cells,rows or columns. Use Arrays. First you hold the value in array and work with the array in memory.
Try to minimize the interaction with the Workbook/Worksheet/sheets.
It will make you code less slow and less error prone.
Here is the code for your reference :
Function getsum()
Dim wb As Workbook
Dim ws As Worksheet
Dim tot_row As Long
Dim row_to_start As Long
Dim cl As Long
Dim irow As Long
Dim sumarr As Variant ' Declare the array
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
sumarr = ws.Range("A1").CurrentRegion ' Put the current region in the array
tot_row = UBound(sumarr, 2) 'Get total rows
row_to_start = tot_row - 2 ' Get the rows from where sum process with start
For cl = row_to_start To UBound(sumarr, 2) ' start from 3rd last column till last column
For irow = LBound(sumarr) + 1 To UBound(sumarr) ' from second row to the last row
msum = msum + sumarr(irow, cl) ' do the sum
Next irow
Next cl
getsum = msum ' return the sum
End Function
Thanks a lot for your precious time to reply.
I have found a solution in Excel VBA macro and it works very fine!!
Dim start As Integer
Dim Mid As Integer
Dim finish As Integer
start = LastCol - 2
Mid = LastCol - 1
finish = LastCol
For i = 2 To LastRow
For j = start To LastCol
If Not IsEmpty(Range("D" & i).Value) Then
Cells(i, LastCol + 1).Formula = "=SUM(" & Cells(i, start).Address & ":" & Cells(i, finish).Address & ")"
End If
Next j
Next i
I'm struggling to write the correct code to be able to Copy and Paste Values for non-blank values with matching criteria.
An example of what I'm trying to do can be seen here (Example)
What I would like the code to do is to take the values in the left hand range that are not blank, and paste the values into the right hand range where they match according to the labels in row A.
If the new values could paste as a highlighted color that would be helpful as well; however, my main struggle is mainly with the first part. (Picture of how it would look after the macro has run) - (Answer)
I have been able to figure this out by using excel formulas within my code; however, this is not ideal for the functionality of my workbook.
Thanks for the help! - It's much appreciated.
Update:
Sub Button2_Click()
Worksheets("Nielson").Range("AH3:CD9999").Formula = "=if(NOT(ISBLANK(vlookup($a3,Load!$P:$AD,Load!R$4,False))),iferror(vlookup($a3,Load!$P:$AD,Load!R$4,False),ch3),ch3)"
Worksheets("Nielson").Range("AH3:CD9999").Copy
Worksheets("Nielson").Range("CH3:CT9999").PasteSpecial xlPasteValues Worksheets("Nielson").Range("CH3:CT9999").Copy
Worksheets("Nielson").Range("AH3:CD9999").PasteSpecial xlPasteValues
End Sub
(code posted as comment by OP)
This can help you. Is a modification of this code.
Private Sub Button2_Click()
Dim vReplacementArray() As Variant
Dim iLastRowReplacements As Integer
Dim iLastRowData As Integer
Dim i As Integer, j As Integer, r As Integer, c As Integer
Dim ValToFind1 As String
iLastRowReplacements = Worksheets("Nielson").Cells(Rows.Count, 1).End(xlUp).Row
iLastRowData = Worksheets("Nielson").Cells(Rows.Count, 9).End(xlUp).Row
'Create an array with replacement data (left 6 columns in your example)
For i = 2 To iLastRowReplacements
ReDim Preserve vReplacementArray(1 To 6, 1 To i)
'You can loop here. I leave it hard-coded to make it clearer
vReplacementArray(1, i) = Worksheets("Nielson").Cells(i, 1).Value
vReplacementArray(2, i) = Worksheets("Nielson").Cells(i, 2).Value
vReplacementArray(3, i) = Worksheets("Nielson").Cells(i, 3).Value
vReplacementArray(4, i) = Worksheets("Nielson").Cells(i, 4).Value
vReplacementArray(5, i) = Worksheets("Nielson").Cells(i, 5).Value
vReplacementArray(6, i) = Worksheets("Nielson").Cells(i, 6).Value
Next
For i = 2 To iLastRowData 'Scan all rows with data, starting in row 2 (row 1 for titles)
'Get values from column I (ValToFind1)
ValToFind1 = Worksheets("Nielson").Cells(i, 9).Value
'Find those to values in the array, and write the replacement in their respective column
For c = 1 To UBound(vReplacementArray, 2)
If (vReplacementArray(1, c) = ValToFind1) Then
For j = 1 To 5 'The five columns (J to N in your example)
If (vReplacementArray(j + 1, c) <> "") Then 'if there is a value
Worksheets("Nielson").Cells(i, 9 + j).Value = vReplacementArray(j + 1, c)
Worksheets("Nielson").Cells(i, 9 + j).Interior.ColorIndex = 4
End If
Next j
End If
Next c
Next i
End Sub
What I am trying to do is take a column of data and transpose it into a single header row, but space out each record such that 'Sheet1'A1 -> 'Sheet2'B1, 'Sheet1'A2 -> 'Sheet2'G1 and so on. (i.e. spaced out every 5 columns)
I am brand new so I was playing around with a loop such that:
Dim i As Integer
Dim j As Integer
i = 1
j = 1
Do While i < 200
Cells(1, i + 1).Value = "='Project List'!A1"
i = i + 5
j = j + 1
Loop
I was trying to use the Int 'j' as a way to cursor through the cell reference in "='Project List'!A1" but can't seem to find a way to do it. I attempted recording a macro but it was using the FormulaR1C1 = "='Project List'!RC[-1]" format and I couldn't figure out how step through R1C1 references either. The 200 was an arbitrary number so that I would capture the whole list of projects, I'm still trying to find a "repeat to blank" style of reference.
Does anyone have any suggestions on how to step through my column of data? Loop? Is there a better way of doing this?
Thanks,
Dane
There are tons of ways to do this but yours is a viable method with some slight modifications. You should create Worksheet objects to reference your input and output worksheets. My code also implements the repeat til blank logic you requested. As you can see, I commented out the first of the outWS lines. Either of those two lines will do the job. Keep the formula one if you need the values to update dynamically. Otherwise use the other one. Obviously you can change Book7.xlsm and Sheet2 as needed. You can also swap Workbooks("Book7.xlsm") for ThisWorkbook if the code is in the same spreadsheet as the data.
Sub transposeAndSpace()
Dim i As Integer
Dim j As Integer
Dim inWS As Worksheet, outWS As Worksheet
i = 1
j = 1
Set inWS = Workbooks("Book7.xlsm").Worksheets("Project List")
Set outWS = Workbooks("Book7.xlsm").Worksheets("Sheet2")
Do While inWS.Cells(j, 1).Value <> ""
'outWS.Cells(1, i + 1).Formula = "='Project List'!A" & j
outWS.Cells(1, i + 1).Value = inWS.Cells(j, 1).Value
i = i + 5
j = j + 1
Loop
Set inWS = Nothing
Set inWS2 = Nothing
End Sub
Assuming the Do/While loop is working for you:
i = 1
j = 1
Do While i < 200
Worksheets("Sheet2").Cells(1, i + 1).Value = "='Project List'!" & Range("A1").Offset(,j).Address
i = i + 5
j = j + 1
Loop
When i & j = 1, this should yield:
Worksheets("Sheet2").Cells(1, i + 1).Value --> Sheet2.Range("B1").Value
And it will put the formula:
"='Project List'!$A$1`
When i = 6, j = 2, should yield:
Worksheets("Sheet2").Cells(1, i + 1).Value --> Sheet2.Range("G1").Value
And it will put the formula:
"='Project List'!$A$2`
etc.
I need a macro which will copy each unique row within a spreadsheet and insert copied rows in the two rows directly beneath the original copied row and then repeat for each row there after.
It would be great if the macro could also input the following text strings - "(A)" in the original copied row, "(B)" in the second and "(C)" in the third.
The text string part isnt hugely important as I can always just use a concatenate formula if required.
Screenshot of what Im trying to achieve:
Assuming the data is in column A and you want the result in column C (as per your picture), this should work:
Public Sub doIt()
Dim data As Variant
Dim modifiedData As Variant
Dim i As Long
Dim j As Long
data = ActiveSheet.UsedRange.Columns(1)
ReDim modifiedData(1 To (UBound(data, 1) - 1) * 3 + 1, 1 To 1) As Variant
modifiedData(1, 1) = data(1, 1) 'header
j = 2
For i = 2 To UBound(data, 1)
modifiedData(j, 1) = "(A) - " & data(i, 1)
modifiedData(j + 1, 1) = "(B) - " & data(i, 1)
modifiedData(j + 2, 1) = "(C) - " & data(i, 1)
j = j + 3
Next i
With ActiveSheet
.Cells(1, 3).Resize(UBound(modifiedData, 1), 1) = modifiedData
End With
End Sub