I'm trying to write a macro to copy the contents of cell A1 of sheet wsVN to the first open cell in column F of sheet wsVL, then copy A2 to the next open cell in F, then A3 to the next and so on up to A305. Sheet VL has a header row with the first open cell being F2. That's where I'm trying to past A1. Then I have a couple rows with data then another open cell where I'd like to past A2. Then 5 rows of data before the next open cell where A3 should go. Here is as close as I have made it so far:
Sub Data_Transfer()
'
' Data_Transfer Macro
' Transfers VariableNames Data to the next available row of sheet VariableList.
Dim lastRow As Integer
Dim wsVN As Worksheet
Dim wsVL As Worksheet
Dim sourceRange As Range
Dim targetRange As Range
Set wsVN = Worksheets("VariableNames")
Set wsVL = Worksheets("VariationList")
If Len(wsVL.Range("F1").Value) > 0 Then
lastRow = wsVL.Range("F2").End(xlDown).Row
Else
lastRow = 2
End If
Set sourceRange = wsVN.Range("A1")
Set targetRange = wsVL.Range("F" & lastRow).Offset(1, 0)
sourceRange.Copy
targetRange.PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
Hopefully someone will offer some guidance on this. It would be appreciated very much!
Thanks
Try this, adjusting sheet names to suit.
Sub x()
Dim r As Range
With Worksheets("Sheet1") 'source sheet
For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Worksheets("Sheet2").Range("F:F").SpecialCells(xlCellTypeBlanks)(1).Value = r.Value 'destination sheet
Next r
End With
End Sub
More on SpecialCells.
Related
Sub Start()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("1")
Set ws2 = Sheets("2")
Dim LastRow As Long, i As Long
LastRow = Cells(Rows.Count, "D").End(xlUp).row
For i = 1 To LastRow
ws1.Range("D" & i).copy
ws2.Range("A2").PasteSpecial Paste:=xlPasteFormats
Next i
If ws1.Range("A" & i) = vbNullString Then
Exit Sub
End If
End Sub
I'm trying to make it so this code pastes the interior fill from column D, Into Column A, unless there is already interior fill present.
Any input appreciated.
Edit: I'm trying to copy the format (interior fill) from Sheet 1 and Sheet 2's Column A's (until the last row) and paste it to Sheet Column A. I'm trying to copy over once cell at a time, and ignore if there is already fill present in sheet 3, because my I dont want the format from sheets 1 and 2 to overwrite eachtoher.
I need to copy data from the 8th row into another sheet(sheet 2). I only need to copy every other cell, it should copy cell C8(first cell where the value is), E8, G8, I8 and so on from all the upto cell IK8.
Is there any way to do this? I have tried the step function in the for loop but its not working and only selecting one cell.It only pastes one value for cells H2:H130.
Sub Workplace()
Dim rng As Range
Dim LastRow As Long
Dim I As Long
LastRow = Worksheets("Questions").Range("C" & Rows.Count).End(xlUp).Row
For I = 8 To LastRow Step 3
Set rng = Worksheets("Questions").Range("C" & I)
rng.Copy
Next I
Worksheets("Sheet1").Range("H2:H130").PasteSpecial Transpose:=True
End Sub
You need to increment the column, not the row.
And move the paste inside the loop, though you need to increment the destination cell.
For i = 3 to 245 Step 2 ' column C to column IK
Set rng = Worksheets("Questions").Cells(8, i)
With Worksheets("Sheet1")
Dim dest as Range
Set dest = .Range("H" & .Rows.Count).End(xlUp).Offset(1)
End With
rng.copy Destination:=dest
Next
Or better, just use Union to build up a range to copy and then copy in one step:
For i = 3 to 245 Step 2 ' column C to column IK
If rng Is Nothing Then
Set rng = Worksheets("Questions").Cells(8, i)
Else
Set rng = Union(rng, Worksheets("Questions").Cells(8, i))
End If
Next
rng.Copy
Worksheets("Sheet1").Range("H2").PasteSpecial Transpose:=True
Application.CutCopyMode = False
EDIT:
"Is there a way to paste it in the first empty cell for Row H in sheet 1 instead of giving it a range?"
Yes, like the following:
Worksheets("Sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Transpose:=True
I want to copy the data one excel to another excel
My question:
In the one workbook Sheet1 column C & D contains some data that data i need to copy another excel that's in closed condition presently. I need to copy Range("C" , i) and Range("D" , i) in to another excel sheet3 B2 and C2 accordingly. in that mainthing each rows copy paste into different workbooks i given a path in H Columns
Sub sbCopyRangeToAnotherSheet()
Dim Openfile As String
Dim lstrow As Long
Dim i As Long
lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To lstrow
'Copy the data
Sheets("Main").Range("C:D", i).Copy
'Activate the destination worksheet
Workbook.Openfile = Range("H", i)
Sheets("Sheet3").Activate
'Select the target range
Range("B2:C2").Select
'Paste in the target destination
ActiveSheet.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next
End Sub
Error Screenshot
Goal: Have the column header of any text in red be represented in column F of the same row as the text.
Problem: Code currently references active row, and for some reason copies F2 (which is written in red). I know the code currently would be attempting to copy/paste over a cell a few times, and I'll work that out later.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, ActiveCell.Column).Copy
Range("F" & (ActiveCell.row)).Select
ActiveSheet.Paste
End If
Next cell
Next row
End Sub
Not sure if I follow your logic. Your problem is that you reference active cell but you are not defining it or changing it other than through the pasting. I think you mean to reference cell (?)
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, cell.Column).Copy Range("F" & cell.row)
End If
Next cell
Next row
End Sub
You are never changing the active cell, so the copy command is always called on row 2 of the active cell, which much be in the F column. I changed the code below to fix the issue.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet ' this should be improved to point at the correct worksheet by name
Set rng = ws.Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
cell.Copy
ws.Range("F" & (cell.row)).PasteSpecial
End If
Next cell
Next row
End Sub
I have small set of data in excel with 4 columns
File A:
SNO TYPE CountryA CountryB CountryD
1 T1 A1 B2 D1
2 T2 A2 B2 D2
and i have this data in another excel file
File B:
SNO TYPE CountryB CountryA CountryC
11 T10 B10 A10 C10
22 T20 B20 A20 C20
33 T30 B30 A30 C30
Now if i want to paste the data in file B over the data in file A, i want the column names to align automatically using some vba code.
So the End result should look like,
SNO TYPE CountryA CountryB CountryC CountryD
1 T1 A1 B1 -- D1
2 T2 A2 B2 -- D2
11 T10 A10 B10 C10 --
22 T20 A20 B20 C20 --
33 T30 A30 B30 C30 --
This should work for you:
Sub MatchUpColumnDataBasedOnHeaders()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Set ws = wbk.Sheets(1)
Set ws2 = wbk.Sheets(2)
Dim cell As Range
Dim refcell As Range
Application.ScreenUpdating = False
ws.Select
For Each cell In ws.Range("A1:Z1")
cell.Activate
ActiveCell.EntireColumn.Copy
For Each refcell In ws2.Range("A1:Z1")
If refcell.Value = cell.Value Then refcell.PasteSpecial (xlPasteValues)
Next refcell
Next cell
Application.ScreenUpdating = True
End Sub
It's funny, I have this feeling there is a really easy non-VBA way to do this - but I couldn't find the button for it on google. This will work for columns A to Z on sheets 1 and 2. This assumes your headers are in row 1.
EDIT - IN ADDITION:
I noticed that you wanted to do this with files and you didn't say anything about sheets. This is how you would do it with different workbooks:
Sub MatchUpColumnDataBasedOnHeadersInFiles()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Workbooks.Open Filename:="C:\PasteIntoWorkbook.xlsx"
Set wbk2 = Workbooks("PasteIntoWorkbook.xlsx")
Set ws = wbk.Sheets(1)
Set ws2 = wbk2.Sheets(1)
Dim cell As Range
Dim refcell As Range
wbk.Activate
Application.ScreenUpdating = False
ws.Select
For Each cell In ws.Range("A1:N1")
wbk.Activate
ws.Select
cell.Activate
ActiveCell.EntireColumn.Copy
wbk2.Activate
ws2.Select
For Each refcell In ws2.Range("A1:N1")
If refcell.Value = cell.Value Then refcell.PasteSpecial (xlPasteValues)
Next refcell
Next cell
ws2.Select
Range("A1").Select
wbk.Activate
ws.Select
Range("A1").Select
Application.ScreenUpdating = True
End Sub
So if were heart-set on working with different .xls files, then that is how yo would do that. You obviously would just need to adjust the file path to whatever your paste-into file would be.
Match column coding
Sheet2 = Your original HEADERS ( Only required headers - Put them into row 1 )
Sheet1 = your data along with the headers but headers are not in sync which could be having more headers or less but you want your data as per the headings present in the sheet2
now put your data into sheet2 ( in row 2 ) below the headers which are already present into sheet2 and run the below coding and your data will appear as per the required headers.
Sub Rahul()
Dim Orig_Range As Range
Dim New_Range As Range
Dim ToMove As Range
Dim RowOld, RowNew As Long
Dim ColOld, ColNew As Long
Dim WSD As Worksheet
Dim Cname As String
Set WSD = ActiveSheet
ColOld = WSD.Cells(1, Application.Columns.Count).End(xlToLeft).Column
ColNew = WSD.Cells(2, Application.Columns.Count).End(xlToLeft).Column
RowNew = WSD.Cells(Application.Rows.Count, 1).End(xlUp).Row
RowOld = 1
Set Orig_Range = Range(WSD.Cells(1, 1), WSD.Cells(1, ColOld))
For i = 1 To ColOld
Set New_Range = Range(WSD.Cells(2, 1), WSD.Cells(2, ColNew))
Cname = Orig_Range.Cells(RowOld, i).Value
Set ToMove = New_Range.Find(what:=Cname, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=True)
If ToMove Is Nothing Then
New_Range.Cells(1, i).Resize(RowNew, 1).Select
Selection.Insert shift:=xlToRight
ElseIf Not ToMove.Column = i Then
ToMove.Resize(RowNew, 1).Select
Selection.Cut
New_Range.Cells(1, i).Select
Selection.Insert shift:=xlToRight
End If
Next i
End Sub