I have columns in 3 excel sheets like this:
Sheet1
ColA ColB
5 4
5 5
45 56
56 56
Sheet2
ColA ColB
53 24
55 55
Sheet3
ColA ColB
45 56
56 56
3 4
I want to copy paste columns from sheet 2 and 3 to sheet 1 and I am not sure of the row numbers as they can change based on the data.
Can anyone tell me the macro code to this without being sure of last data row in excel sheet.
I would really appreciate your suggestion.
If you just want to move the values, the following is what you are after. If you want to move the formatting as well, ask.
Sub CopyToSheet1()
Dim Row1Max As Long
Dim Row1Next As Long
Dim Row23Max As Long
Dim Values() As Variant
' Find bottom rows of sheets 1 and 2
' These statements position a virtual cursor to the bottom of column 1
' and then move up until they find data. For Sheet 1 it adds one because
' it needs the first blank row
Row1Next = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
Row23Max = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
' Extract data from sheet 2
Values = Worksheets("Sheet2").Range("A1:B" & Row23Max).Value
' Drop into sheet 1
Row1Max = Row1Next + Row23Max - 1
Worksheets("Sheet1").Range("A" & Row1Next & ":B" & Row1Max).Value = Values
Row1Next = Row1Max + 1
' Find bottom row of sheet3
Row23Max = Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row
' Extract data from sheet 3
Values = Worksheets("Sheet3").Range("A1:B" & Row23Max).Value
' Drop into sheet 1
Row1Max = Row1Next + Row23Max - 1
Worksheets("Sheet1").Range("A" & Row1Next & ":B" & Row1Max).Value = Values
End Sub
I have often used a function
Function CountRows(r as Range) As Long
CountRows = r.Worksheet.Range(r,r.End(xlDown)).Rows.Count
End Function
Then to copy and paste
Sub CopyRange(r_src as Range, r_dst as Range, numrows as Long, numcols as Long)
r_dst.Resize(numrows,numcols).Value2 = r_src.Resize(numrows,numcols).Value2
End Dub
Which you use it like this
Dim N as Long
Dim r_dst as Range, r_src as Range
' Pick first cell on sheet 1
Set r_dst = Sheet1.Range("A1")
' Count existing data and move to end
N = CountRows(r_dst)
Set r_dst = r_dst.Offset(N,0)
' Pick first cell of sheet 2 and count rows
Set r_src = Sheet2.Range("A1")
N = CountRows(r_src)
' Copy rows to sheet 1
CopyRange r_src, r_dst, N, 2
' Move to end of data on sheet 1
Set r_dst = r_dst.Offset(N,0)
' Pick first cell on sheet 2 and count rows
Set r_src = Sheet3.Range("A1")
N = CountRows(r_src)
' Copy rows to sheet 1
CopyRange r_src, r_dst, N, 2
Related
in one column i have data
1
2
3
1
2
1
5
6
After 1 want to add new row and add the column data into rows
i want the out as
1 2 3
1 2
1 5 6
If you have data like this:
Just copy the data:
Then click on the Paste above and then select Paste Transpose:
Finally, your output data looks like what you are looking for:
I'm afraid you'll need VBA for this. You can use this code on a module, make sure the active sheet is the one with the values to transpose and then execute it:
Sub custom_transpose()
Dim i As Long
Dim MyValues As Variant
Dim InitialRow As Long
Dim ThisColumn As Long
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
MyValues = Range("A1:A" & LR).Value
InitialRow = 0
For i = 1 To UBound(MyValues) Step 1
If MyValues(i, 1) = 1 Then
'because it's a one, we start a new row at column 2 (Column B)
InitialRow = InitialRow + 1
ThisColumn = 2
Cells(InitialRow, ThisColumn).Value = 1
Else
'we keep same row but increase column number
ThisColumn = ThisColumn + 1
Cells(InitialRow, ThisColumn).Value = MyValues(i, 1)
End If
Next i
Erase MyValues 'clear array
End Sub
I have an Excel table which may contain such:
Screenshot of content from a table, columns C and D
It may be much longer
on top of column D may be an empty cell, but after that it is always the same sequence of contents repeating.
I want to copy and paste in another sheet, with transpose, the contents of the neighboring cells, that is in C, so it would look like:
a screenshot from destination table
It is easy to copy the header, but I am completely unable to have the code loop through and copy all the column C contents that appear left to what is between 1tst and 27tst in the original column D, until all of the blocks of data are copied.
To complicate things even further, I want all empty cells in this destination table to take the value from the cell above, basically filling the blanks that way. This would then look like
Final look of the destination table
In this example, the Words "Algeria | DZ" have to be automatically copied down. The cell under "24tst" remains blank as there is nothing but the header preceding this row.
I have absolutely no starting code here, as these data already made a long process from a Word file through a csv using Ruby, and then the csv is read in and reformatted into various sheets in the Excel file with already long line sof code. That all works so far, but these are my missing steps.
Any help is greatly appreciated. I only started coding again 3 weeks ago, after having never programmed in VBA but years ago in perl and R.
-- In response to VBasic2008 and to try that out I made now a test spreadsheet that looks this way:this is closer to what it really looks like
I changed the constants here:
enter code hereConst sName As String = "Tabelle1" ' Source Worksheet Name
enter code hereConst sFirst As String = "C2" ' Source First Cell Address
enter code hereConst tName As String = "Tabelle2" ' Target Worksheet Name
enter code hereConst tFirst As String = "B1" ' Target First Cell Address
The groups will actually be constant in length, actually more than 11, but that can be fixed later.
These:
1tst
2tst
3tst
11tst
4tst
22tst
23tst
24tst
25tst
26tst
27tst -
I pasted this already into target sheet.
What I get from my test using my thus modified solution from VBasic2008 is this:
Afghanistan | AF Åland Islands | AX Albania | AL Algeria | DZ American Samoa | AS Belgium | BE Belize | BZ 24tst Bermuda | BM Bhutan | BT Bolivia | BO
Bonaire, Sint Eustatius and Saba | BQ Bosnia and Herzegovina | BA Botswana | BW Algeria | DZ Brazil | BR Christmas Island | CX Cocos (Keeling) Islands | CC Colombia | CO Comoros | KM n/a Congo | CD
This is almost perfect, except for it should not, in the first row in the target sheet after the headers, copied down the "24tst". Can this still be tweaked?
A Copy Transpose
This will work correctly only if the data is consistent i.e. 11 rows of data and 1 empty (Next-Group) row (can be changed in the constants section) i.e. if you have 5 data sets, there has to be 60 rows of data. If there is 65, only 60 will be processed and if there is 59, only 48 will be processed.
The following image shows what the current setup in the code will produce (without the formatting).
The Code
Option Explicit
Sub transposeData()
Const sName As String = "Sheet1" ' Source Worksheet Name
Const sFirst As String = "A2" ' Source First Cell Address
Const tName As String = "Sheet1" ' Target Worksheet Name
Const tFirst As String = "D1" ' Target First Cell Address
Const NoE As Long = 11 ' Number of Elements
Const NoER As Long = 1 ' Number of Empty Rows
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Worksheet ('ws').
Dim ws As Worksheet
Set ws = wb.Worksheets(sName)
' Define Source First Cell ('First').
Dim First As Range
Set First = ws.Range(sFirst)
' Define Source Last Cell ('Last').
Dim Last As Range
Set Last = First.Offset(ws.Rows.Count - First.Row, 1).End(xlUp)
If Last.Row - First.Row + 1 < NoE Then
GoTo ProcExit
End If
' Define Source Range ('rng').
Dim rng As Range
Set rng = ws.Range(First, Last)
' Write values from Source Range to Source Array ('Source').
Dim Source As Variant
Source = rng.Value
' Define number of Data Sets ('NoDS').
Dim NoDS As Long
NoDS = Int(UBound(Source, 1) / (NoE + NoER))
' Define Target Number of Rows ('NoR').
Dim NoR As Long
NoR = NoDS + 1
' Define Target Array ('Target').
Dim Target As Variant
ReDim Target(1 To NoR, 1 To NoE)
' Declare additional variables for the upcoming loops.
Dim CurrentValue As Variant ' Source Current Value
Dim CurrentLR As Long ' Source Current Last Row
Dim j As Long ' Target Columns Counter
Dim i As Long ' Target Rows Counter
' Write headers.
For j = 1 To NoE
Target(1, j) = Source(j, 2)
Next j
' Write data.
For i = 2 To NoR
CurrentLR = (i - 2) * (NoE + NoER)
For j = 1 To NoE
CurrentValue = Source(CurrentLR + j, 1)
If Not IsEmpty(CurrentValue) Then
Target(i, j) = CurrentValue
Else
Target(i, j) = Target(i - 1, j)
End If
Next j
Next i
' Define Target Worksheet ('ws').
Set ws = wb.Worksheets(tName)
' Define Target First Cell ('First').
Set First = ws.Range(tFirst)
' Define Target Range ('rng').
Set rng = First.Resize(NoR, NoE)
' Write values from Target Array to Target Range.
rng.Value = Target
' Inform user
MsgBox "Data transferred.", vbInformation, "Success"
ProcExit:
End Sub
EDIT
Tiny Change
Instead of Target(i, j) = Target(i - 1, j) use
If i > 2 Then
Target(i, j) = Target(i - 1, j)
End If
I think the easiest way of doing this is looping through cells with headers and checking each value.
When you find your "next-group" cell then trigger some ifs;
Example program which covers your problem below:
Sub solution()
'Set first row
Dim firstrow As Integer
firstrow = 1
'Find last row
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row 'Go to bottom of file and jump up to last non-empty cell
'Set first column
Dim firstcolumn As Integer
firstcolumn = 1
'find last column
Dim lastcolumn As Integer
lastcolumn = 2
'Set first cell of target table
Dim targetrange As Range
Set targetrange = Range("E2")
Dim i As Integer
Dim cnt As Integer 'conuter for creating offset (for columns)
Dim cnt2 As Integer 'conuter for creating offset (for rows)
'Copy headers
cnt = 0
For i = firstrow To lastrow
If Cells(i, lastcolumn).Value = "next-group" Then Exit For
Cells(i, lastcolumn).Copy targetrange.Offset(0, cnt)
cnt = cnt + 1
Next i
'Copy data
cnt = 0
cnt2 = 1
For i = firstrow To lastrow
'If we have text "next group"
If Cells(i, lastcolumn).Value = "next-group" Then
cnt = 0 'start with first column
cnt2 = cnt2 + 1 'Start with next row
'This cell is not copied
Else
'cell is copied
Cells(i, firstcolumn).Copy targetrange.Offset(cnt2, cnt)
'column counter is increased
cnt = cnt + 1
End If
Next i
'Change blank cells in current region into formula which points to cell one row above
'targetrange.CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
'Same formula but keep cells in first row of data blank istead copying header
Dim targetArea As Range
Set targetArea = targetrange.CurrentRegion
targetArea.Offset(2).Resize(targetArea.Rows.Count - 2).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub
I didn't cover case when you have empty cell in first row as you didn't described what you're expecting (at this moment it have same formula so it will be filled with header value).
UPDATE: I didnt put "=" inside R1C1 formula, now its fixed.
UPDATE2: Changed part of filling empty cells so it skips first 2 rows (Headers and first row of data) instead filling it as mentioned in question update
I am quite new to VBA so my question may sound silly to some of you.
I have a problem with my code. I am trying to check between 2 sheets(1st: test and 2nd: test data. In the code I am using the code name of the sheets) how may times a criteria/my product is met and based on that number to add that many rows beneath the SKU/product.
What I want to do is, if for my first product/SKU I have stock in 5 different locations, I want to add 5 rows in the first sheet and to see the qty in column D and the location in column E.
TestData tab
The reason why I need to list the quantity in different cells is that the stock is in different locations, so I can not just add in to one cell.
I am also adding screen shots of how my two sheets look like.
I have not add the loop to find the location yet, but I want to understand how to add the rows first.
Sub test()
Dim myrange As Range, testrange As Range, cell As Range, result As Range
Dim i As Long, testlastrow As Long, lastrow As Long
Dim helprng As Range
lastrow = TESTTAB.Range("a" & Rows.Count).End(xlUp).row
testlastrow = TDATA.Range("a" & Rows.Count).End(xlUp).row
Set testrange = TDATA.Range("a2:c" & testlastrow)
Set myrange = TESTTAB.Range("b2:b" & lastrow)
Set result = TESTTAB.Range("d2:e" & testlastrow)
Set helprng = TESTTAB.Range("f2:f" & lastrow)
For Each cell In myrange
For i = 1 To lastrow
If cell.Cells(i, 1) = testrange.Cells(i, 1) Then
result.Cells(i, 1) = testrange.Cells(i, 2)
End If
Next i
Next cell
End Sub
Here is the raw structure you were asking for.
Sub test()
' 011
Dim Rng As Range
Dim Tmp As Variant
Dim Radd As Long ' number of rows to add
Dim R As Long ' row counter
With Tdata
' Range, Cells and Rows Count, all in the same sheet
' exclude caption row(s)
Set Rng = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
Application.ScreenUpdating = False ' speed up the process
With TestTab
' end the loop in row 2 because row 1 might contain captions
' loop bottom to top because row numbers will change
' below the current row as you insert rwos
' column 1 = "A"
For R = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
Tmp = .Cells(R, 1).Value
Radd = Application.CountIf(Rng, Tmp)
If Radd > 1 Then
.Range(.Rows(R + 1), .Rows(R + Radd)).Insert
.Cells(R + 1, 1).Value = Radd ' for testing purposes
End If
Next R
End With
Application.ScreenUpdating = True ' now you look
End Sub
As our Evil Blue Monkey has suggested, inserting blank rows and then populating them may not be the most efficient way. You can copy a row and then click Insert to insert the copied data into a new row. Get the syntax from the Macro recorder if it's of interest. It works with the Range object the same way.
I'm currently using excel 2010 and have some data I'm trying to transform so to speak and output the results into sheet 2. I'm not sure where to start and was hoping for some guidance.
The image below is only a sample set of data. The actual spreadsheet consists of 92 rows and 78 columns. The first three columns are name and address and the rest are very similar to what is shown in the image. Some cells have a value, a zero, or blank. The rows in red is what I would like to accomplish.
Here is a solution using VBA.
It assumes that your existing sheet is named "Sheet1", and the new sheet exists and is named "Sheet2".
Option Explicit
Sub CollapseData()
Dim RowNbr As Long
Dim SrcColNbr As Long
Dim DestColNbr As Long
Dim MaxRowNbr As Long
Dim PeriodNbr As Long
Dim MaxPeriodNbr As Long
Dim SrcSheetName As String
Dim DestSheetName As String
Dim SrcSheet As Worksheet
Dim DestSheet As Worksheet
SrcSheetName = "Sheet1"
DestSheetName = "Sheet2"
Set SrcSheet = ThisWorkbook.Worksheets(SrcSheetName)
Set DestSheet = ThisWorkbook.Worksheets(DestSheetName)
' Determine last row number in use
MaxRowNbr = SrcSheet.Cells(Rows.Count, 1).End(xlUp).Row
' Copy name, addr1, and addr2 headings
For DestColNbr = 1 To 3
Call CopyCell(SrcSheet.Cells(1, DestColNbr), DestSheet.Cells(1, DestColNbr))
Next DestColNbr
' Determine number of period columns in use
MaxPeriodNbr = SrcSheet.Cells(1, Columns.Count).End(xlToLeft).Column - 3
' Generate date headings
DestColNbr = 4
For PeriodNbr = 1 To MaxPeriodNbr
DestSheet.Cells(1, DestColNbr) = "date" & Format(PeriodNbr, "##0")
DestSheet.Cells(1, DestColNbr + 1) = "amount" & Format(PeriodNbr, "##0")
DestColNbr = DestColNbr + 2
Next PeriodNbr
' Copy data from Sheet1 to Sheet2
For RowNbr = 2 To MaxRowNbr
' Copy name and address
For DestColNbr = 1 To 3
Call CopyCell(SrcSheet.Cells(RowNbr, DestColNbr), DestSheet.Cells(RowNbr, DestColNbr))
Next DestColNbr
DestColNbr = 4
For SrcColNbr = 4 To MaxPeriodNbr + 3
If SrcSheet.Cells(RowNbr, SrcColNbr) <> 0 Then
' Copy date from Sheet1 to Sheet2
Call CopyCell(SrcSheet.Cells(1, SrcColNbr), DestSheet.Cells(RowNbr, DestColNbr))
' Copy amount from Sheet1 to Sheet2
Call CopyCell(SrcSheet.Cells(RowNbr, SrcColNbr), DestSheet.Cells(RowNbr, DestColNbr + 1))
DestColNbr = DestColNbr + 2
End If
Next SrcColNbr
Next RowNbr
End Sub
Private Sub CopyCell(FromCell As Range, ToCell As Range)
FromCell.Copy
ToCell.PasteSpecial xlPasteValues
ToCell.PasteSpecial xlPasteFormats
End Sub
Here is how you can do it for the example you have shown. It should be simple to replicate the formulas for the whole set of data you have.
To get the first date that has an amount greater than zero, i am doing an array multiplication of the amounts array > 0 and the dates array. then i invert this array (1/array). AGGREGATE function gives you the largest value after ignoring the erros(#div0). Inverting again gives you the first date that has an amount greater than 0.
for the next date, i include one more criteria by checking if the date array has date greater than the date previously calculated, thus giving me the next date.
The formula for amounts are basically HLOOKUPs for the date that was retrieved.
for date 1
=1/AGGREGATE(14,6,1/((D2:I2>0)*D1:I1),1)
for amount 1
=HLOOKUP(D6,$D$1:$I$2,2,FALSE)
for date 2
=1/AGGREGATE(14,6,1/(($D$2:$I$2>0)*($D$1:$I$1>D6)*$D$1:$I$1),1)
for amount 2
=HLOOKUP(F6,$D$1:$I$2,2,FALSE)
for date 3
=1/AGGREGATE(14,6,1/(($D$2:$I$2>0)*($D$1:$I$1>F6)*$D$1:$I$1),1)
for amount 3
=HLOOKUP(H6,$D$1:$I$2,2,FALSE)
I have a workbook containing 197 sheets. I need to delete all rows in each sheet if the value in column AA is zero. Anyone know how to do this?
If you would like to delete each row if and only if that row's column AA is zero, then the below should work for you.
Sub delete0rows()
Dim Worksheet As Excel.Worksheet
Dim lastRow As Long
Dim i As Integer
For Each Worksheet In Application.ThisWorkbook.Worksheets
lastRow = Worksheet.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
Do While i <= lastRow
If Worksheet.Range("AA" & i).Value = 0 Then
Worksheet.Rows(i).Delete
i = i - 1
lastRow = lastRow - 1
End If
i = i + 1
Loop
Next
End Sub
Note this will only delete the row if the cell value in AA is 0. There are several subtleties here... Excel will show a 0 even if the cell value is '0 or =0 among other things, and those rows will not be deleted with the above code.