Cutting/Pasting Data from column B to first empty cell in Column A - excel

I have just one worksheet that has 6 columns and 10 rows. So the Range of my table is A1:F10 which has 60 cells.
I simply need to cut the data from column B and paste it into the first empty cell in column A. Then, I need it to do the same with columns C - F. Eventually I want to have only one column (Column A) that is 60 rows deep.
Sub Move_Columns()
Range("B1:B10").Copy Destination:=Range("A11")
Range("C1:C10").Copy Desitnation:=Range("21")
' this would continue until columns B-F were copied in column A
End Sub
The problem is that this code only copies the data over. I need it removed once it has been copied. I'm also sure there is a much more efficient way to write the code so that I don't have to keep repeating the ranges.
I wish I knew how to write the code so that Excel will automatically cut and paste the data from each column into the first empty row in column A.
Would the For Each Statement be a good idea to add in there?

I make this code, and put some comments to help you to understand.
Sub MoveAllInFirstColumn()
Dim i As Integer
Dim lastCol As Integer
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column 'finds the last column
For i = 2 To lastCol ' foreach columns except first
Dim lastRow As Integer
lastRow = Cells(Rows.Count, "A").End(xlUp).Row 'get the lastrow of current column
Range(Cells(1, i), Cells(Cells(Rows.Count, i).End(xlUp).Row, i)).Cut Cells(lastRow + 1, 1) 'cut and paste the current column to the first column
Next i
End Sub

To continue with what you have:
Sub Move_Columns()
Range("B1:B10").Copy Destination:=Range("A11")
Range("B1:B10").ClearContents
Range("C1:C10").Copy Desitnation:=Range("A21")
Range("C1:C10").ClearContents
' this would continue until columns B-F were copied in column A
End Sub
An alternative with some looping
Sub Move_Columns()
Dim StartCol as Integer
Dim EndCol as Integer
Dim StartRow as Integer
Dim EndRow as Integer
Dim CurRow as Integer
Dim i as Integer
Dim DestCol as integer
DestCol = 1
StartCol = 2
EndCol = 6
StartRow = 1
EndRow = 10
CurRow = StartRow
for I = StartCol to EndCol
'Range(cells(i, StartRow),cells(i, EndRow).Copy Destination:=Range(DestCol,CurRow)
'Range(cells(i, StartRow),cells(i, EndRow).ClearContents
Range(cells(StartRow, i), cells(EndRow, 1)).Copy Destination:=Range(DestCol, CurRow)
Range(cells(StartRow, i),cells(EndRow,i)).ClearContents
CurRow = CurRow + EndRow
Next
end Sub

Related

Create new line then copy and paste row

Im trying to create an excel macro to select a range of cells then insert new row every other row then copy and paste each row.
For example.
apples
oranges
mangos
My desired goal is
apples
apples
oranges
oranges
mangos
mangos
I have thousands of rows and a macro would be nice.
This Inserts a new row,every other row.
Sub InsertNewRows()
Dim rng As Range
Dim CountRow As Integer
Dim i As Integer
Set rng = Selection
CountRow = rng.EntireRow.Count
For i = 1 To CountRow
ActiveCell.Offset(1, 0).EntireRow.Insert
ActiveCell.Offset(2, 0).Select
Next i
End Sub
How can I duplicate the lines in the range too?
Not inserting rows, this code copies and pastes each value twice. Inserting rows is really time consuming.
Here's a screenshot of before/after running code:
Sub test()
Dim MyData As Variant
Dim LR As Long
Dim i As Long
Dim Initial_Row As Long
LR = Range("A" & Rows.Count).End(xlUp).Row 'last non blank cell in column A
MyData = Range("A1:A" & LR).Value 'all data into array
Initial_Row = 1 'initial row where data starts pasting
For i = 1 To UBound(MyData) Step 1
Range("A" & Initial_Row & ":A" & Initial_Row + 1).Value = MyData(i, 1)
Initial_Row = Initial_Row + 2
Next i
Erase MyData 'delete data
End Sub
I recommend to read the values into an array and duplicate them into another array and finally write that array to the cells. This is much faster than duplicating cells.
Option Explicit
Public Sub DuplicateSelectedRows()
Dim SelRng As Range
Set SelRng = Selection
' read values into array
Dim SelectedValues As Variant
SelectedValues = SelRng.Value
' create output array of double the size
Dim DuplicatedValues As Variant
ReDim DuplicatedValues(1 To UBound(SelectedValues, 1) * 2, 1 To UBound(SelectedValues, 2))
' duplicate values
Dim iRow As Long
For iRow = 1 To UBound(SelectedValues, 1)
DuplicatedValues(iRow * 2 - 1, 1) = SelectedValues(iRow, 1)
DuplicatedValues(iRow * 2, 1) = SelectedValues(iRow, 1)
Next iRow
' output values
SelRng.Cells(1, 1).Resize(RowSize:=UBound(DuplicatedValues)).Value = DuplicatedValues
End Sub

Find a data with a specific title and copy the whole column to another sheet

I would like to create a VBA, to copy my data in "RAW", to paste into sheet "summary" by the specific column arrangement in my "summary" sheet.
for example, if sheet "summary" column A is COUNTER CODE, then copy the data from sheet "RAW" which the data is in B2-B5 and paste into my sheet "summary" A2-A5
I tried to use the below VBA, which it works. but in the event if the column data in "RAW" is different, i will not be getting the correct data.
Sub TRANSFERDATA()
Dim LASTROW As Long, EROW As Long
LASTROW = Worksheets("RAW").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LASTROW
Worksheets("RAW").Cells(i, 1).Copy
EROW = Worksheets("summary").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 2)
Worksheets("RAW").Cells(i, 2).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 1)
Worksheets("RAW").Cells(i, 3).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 4)
Worksheets("RAW").Cells(i, 4).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 3)
Next i
End Sub
Thanks!
summary
RAW
Test the next code, please. Yo do not have to copy cell by cell. In the way the code is designed, it will also work for a header which is not identic with the one in 'RAW' worksheet, but 'RAW' header string is contained:
Sub TestFindCopyInPlace()
Dim shR As Worksheet, shSum As Worksheet, colHeadR As String
Dim colHS As Range, lastCol As Long, lastRow As Long, i As Long
Set shR = Worksheets("RAW")
Set shSum = Worksheets("summary")
lastCol = shR.Cells(1, Columns.count).End(xlToLeft).Column
lastRow = shR.Range("A" & Rows.count).End(xlUp).Row
For i = 1 To lastCol
colHeadR = shR.Columns(i).Cells(1, 1).value
Set colHS = shSum.Rows(1).Find(colHeadR)' find the cell with the header of the one being copied
If Not colHS Is Nothing Then 'Find method will find a column containing colHeadR in its header string...
shR.Range(shR.Cells(2, i), shR.Cells(lastRow, i)).Copy Destination:=colHS.Offset(1, 0)
Else
MsgBox "The column header """ & colHeadR & """ could not be found." & vbCrLf & _
"Please check the spelling or whatever you think it is necessary..."
End If
Next i
End Sub
The code should work for as many columns your 'RAW` worksheet contains...
To make the process fully automatic, please use the following code:
Sub TRANSFERDATA()
Const rawSheet As String = "RAW"
Const summarySheet As String = "summary"
'===================================================================================
' Find the last column in both sheets
'===================================================================================
Dim rawLastCol As Integer
Dim summaryLastCol As Integer
rawLastCol = Worksheets(rawSheet).Cells(1, Columns.Count).End(xlToLeft).Column
summaryLastCol = Worksheets(summarySheet).Cells(1, Columns.Count).End(xlToLeft).Column
'===================================================================================
' Iterate over all columns in the RAW sheet and transfer data to the summary sheet
'===================================================================================
Dim col As Integer
For col = 1 To rawLastCol
'Read column header
Dim header As String
header = Worksheets(rawSheet).Cells(1, col).Value
'Find this header in the summary sheet
Dim col2 As Integer
For col2 = 1 To summaryLastCol
If Worksheets(summarySheet).Cells(1, col2).Value = header Then
'Transfer all values from RAW to the summary sheet
Dim lastRow As Integer
lastRow = Worksheets(rawSheet).Cells(Rows.Count, col).End(xlUp).row
If lastRow > 1 Then 'to handle the case where a column contains no data
'First clear previous data
Range(Worksheets(summarySheet).Cells(2, col2), Worksheets(summarySheet).Cells(lastRow, col2)).ClearContents
'Now, transform data
Dim row As Integer
For row = 2 To lastRow
Worksheets(summarySheet).Cells(row, col2).Value = Worksheets(rawSheet).Cells(row, col).Value
Next row
End If
'Break
Exit For
End If
Next col2
Next col
End Sub
This will work event if the number of columns or rows change in your sheets

How to clear data between first and last row in excel column

I need to clear data between first cell and last cell
in a excel column. I tried this code, but it deletes the data from the entire sheet, I need only for a specific column.
Sub DeleteRow()
Dim i1 As Long
Dim iMax As Long
iMax = Cells.SpecialCells(xlCellTypeLastCell).row
For i1 = iMax - 1 To 2 Step - 1
Rows(i1).EntireRow.Clear
Next i1
End Sub
This would clear content between the first row and the last row in column A.
Sub ClearRows()
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A2:A" & lastRow - 1).ClearContents
End Sub

Excel - Not to copy entire row just rows from Colum E to K to another sheet

I found this Excel VBA code that's very short and clean and it does its job to copy the entire row based on a condition. I added it to my vba project and it works well the only problem is - it copies the entire row.
I am trying to implement the code to only copy rows from Column E to K, but
I have not been successful in tweaking the code to what I am trying to do.
Basically, in worksheet "verification" if Column "AB" = "Final" then copy each row that has "Final" from Column E to K to the worksheet "upload".
I am pulling my hair to make it work, and I have search everywehre and no luck. I know in this platform, I can find the solution to my problem.
I will keep on playing with the code.
Sub CopyEachRowtoUpload()
Application.ScreenUpdating = False
Dim wsI As Worksheet, wsO As Worksheet
Dim LastRow As Long, i As Long, j As Long
Dim LastColumn As Long, a As Long, b As Long
Dim rng As Range
Set wsI = Sheets("Verification")
Set wsO = Sheets("Upload")
Set rng = wsI.Range("E:K")
'Last Row in a Column. Row need to start in row 2
LastRow = wsI.Cells(Rows.Count, "K").End(xlUp).Row
'Last Column in a Row. Rows from Column E to K is what I want to copy
LastColumn = wsI.Cells(5, Columns.Count).End(xlToLeft).Column
'Row start
j = 2
With wsI
'Loop through each row
For i = 1 To LastRow
If Range("AB" & i).Value = "Final" Then
wsI.Rows(i).Copy
wsO.Rows(j).PasteSpecial Paste:=xlPasteValues
j = j + 1
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Just use the Range.Cells property together with the Range.Resize property to locate and shape the source and target.
With wsI
'Loop through each row
For i = 1 To LastRow
If .Range("AB" & i).Value = "Final" Then
wsO.Cells(j, "A").Resize(1, 7) = .Cells(i, "E").Resize(1, 7).Value
j = j + 1
End If
Next i
End With
Direct value transfer is preferred over Copy, Paste Special, Values if all you want is the cell values.
btw, you were missing a . in .Range("AB" & i).Value.

Find, copy and paste all possible values of a cell range

I have a row of cells (the row elements may vary) and another sheet with several columns of data. Let's say on sheet 1 we have 7 columns with data(first column with titles) and on sheet 2 we have some of those titles transposed on the first row. The task is to find all possible values for each title in sheet 2. Let's say in sheet 2 on the first cell we have title X, then I need to find all values corresponding to title X in sheet 1 and to take out the results from the 8th column of sheet 1. then do the same for cell 2 in sheet 2 and so on till the end of the row.
Can someone share a hint or any suggestions that might help me.
Actually I used the following code:
Sheets("sheet2").Select
Dim Lcola As Long
Dim rng As Range
With ActiveSheet
Lcola = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(2, 1), .Cells(2, Lcola))
With rng
Range("A2").Select
ActiveCell.Formula = "=VLOOKUP(A$1,MAP!$A$1:$I$" & lRowc & _
",8,FALSE)"
Selection.AutoFill Destination:=rng, Type:=xlFillDefault
End With
End With
The thing is that I'm not sure how to repeat the function several times, or as much repetitions as I have on each variable from sheet 2 in sheet 1. And another issue that I'm facing is the vlookup function always gives me the first found item.
Use a For loop, with your last Column from Sheet2 as your counter Max.
use iCol to keep track of which Column on Sheet2 you are copying and reading from.
use iRow to keep track of which ROW has the data you want on Sheet1.
Since you know you need the 8th column on the Sheet 1, it will always be Sheets("Sheet1"),Cells(iRow, 8)
and since you know the ROW that the column headers are located in Sheet2, Sheets("Sheet2"),Cells( 1, iCol) - if the header row is 1.
Then just grab a LastRow check on the Sheet2 Column in question and add to it one at a time.
Dim iCol As Integer
Dim lastCol As Integer
Dim lastRow1 As Integer
Dim lastRow2 As Integer
Dim matchRow As Integer
Dim tempVal As String
Dim iRow As Integer
Dim nRow As Integer
Private Sub IndexMatchLoop()
lastCol = Sheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column
For iCol = 1 To lastCol
'Assuming your row on Sheet2 is 1.
tempVal = Sheets("Sheet2").Cells(1, iCol)
iRow = 1
Call GetLastRow
nRow = lastRow2 + 1
'Looks up the value from Sheet2 Column Header on Column1 of Sheet1 one Row at a Time
For iRow = 1 to lastRow1
If Sheets("Sheet1").Cells(iRow, 1) = tempVal Then
'Copy the data from Sheet1 Column 8 in the Rows with the value to Sheet2, the nextRow of the Col
Sheets("Sheet2").Cells(nRow, iCol) = Sheets("Sheet1").Cells(iRow, 8)
nRow = nRow + 1
End If
Next iRow
Next iCol
End Sub
Private Sub GetLastRow()
lastRow1 = Sheets("Sheet1").Cells(65532, 1).End(xlUp).Row
lastRow2 = Sheets("Sheet2").Cells(65532, iCol).End(xlUp).Row
End Sub
EDIT: typo in formula (was relying on autoComplete for "Int" instead of "Integer"
EDIT: Adding Screenshots

Resources