I am trying to have copy a row, copy and paste transpose, then go down a row and loop until the row is empty in value. Here is my Code:
Sub Loop
Dim rng As Range
Set rng = Range("B2:D2")
Dim paste As Range
Set paste = Range("F:F")
Do Until IsEmpty(ActiveCell)
Commits.Select
Selection.Copy
upl.Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= \_
False, Transpose:=True
Commits.Activate
ActiveCell.Offset(rowoffset:=1).Activate
Loop
End Sub
The code creates an infinite loop and I am unsure how to fix it. Here is the final product I want it to look like
Related
data set
Hi All,
I know its abasic stuff but trying to learn VBA and encountered this issue while building my first macro. I have completely no idea how to pull this through.
I have a data set in sheet1 - an array of 9 columns with headers (the range is not definite and will vary month to month) out of which I need to populate the data into a form in sheet2. The problem is that the form is just built manually across spreadsheet2. Someone just drew a table and adapted it as a form and it cannot be changed (just some requirement) Another thing is that table was created in a way where some cells are one above the other so 2 rows would contain the data of one in the source. I placed the photos that should paint the picture of what Im trying to say. So the only thing I knew is how to copy one row of data but have no idea how to loop it so that each next row from spread sheet1 will populate itself accordingly among these two other rows. So the idea is for the macro to copy data from the source and create necessary number of these double rows until the source data runs out(dependantly on how bit source range will be as its dynamic) At the end there must be that summary of TOtal from last row.
Ive tried it like this
Sub sbCopyRangeToAnotherSheet()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
ws1.Sheets("51").Range("H2").Copy
Sheets("Add 51").Range("A11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("51").Range("C2").Copy
Sheets("Add 51").Range("B11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("51").Range("E2").Copy
Sheets("Add 51").Range("D10").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("51").Range("F2").Copy
Sheets("Add 51").Range("D11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("51").Range("D2").Copy
Sheets("Add 51").Range("E11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("51").Range("I2").Copy
Sheets("Add 51").Range("I11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
Untested:
Sub Tester()
Dim rngDest As Range, rwSrc As Range, arr, i As Long
Set rwSrc = ThisWorkbook.Worksheets("51").Range("C2:H2") 'first row of source data
Set rngDest = ThisWorkbook.Worksheets("Add 51").Range("A5:I6") 'destination for first row
arr = Array("B2", "D2", "D1", "E1", "E2", "I2") 'array of *relative* addresses
Do While Application.CountA(rwSrc) > 0 'while there's any data in the source row
For i = 1 To rwSrc.Cells.Count 'loop over cells in source row
'set value of a cell in `rngDest` using relative range address from `arr`
rngDest.Range(arr(i - 1)).Value = rwSrc.Cells(i).Value 'i-1 because arr is zero-based
Next i
Set rwSrc = rwSrc.Offset(1) 'next source row
Set rngDest = rngDest.Offset(rngDest.Rows.Count) 'next destination block
Loop
End Sub
Relies on Range() being relative to the object it's called on, so for example
Range("B2:C4").Range("A1") is B2
Range("B2:C4").Range("B2") is C3
I have the following to copy a range of free text boxes to another series of cells, which works as I want it to:
Public Sub LogEntry()
'define source range
Dim SourceRange As Range
Set SourceRange = ThisWorkbook.Worksheets("Log").Range("C4:J4")
'find next free cell in destination sheet
Dim NextFreeCell As Range
With ThisWorkbook.Worksheets("Log")
If IsEmpty(.Range("C8").Value) Then
Set NextFreeCell = .Range("C8")
Else
Set NextFreeCell = .Cells(.Rows.Count, "C").End(xlUp).Offset(1)
End If
End With
'copy & paste
SourceRange.Copy
NextFreeCell.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NextFreeCell.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'delete text box
ThisWorkbook.Save
Application.Goto Reference:="R4C7:R4C9"
Application.CutCopyMode = False
Selection.ClearContents
End Sub
In my original fields, in box J4, I have a drop down list. How do I copy this to the new location and maintain the list functionality? I also want to add conditional formatting to the selections in this box so would like this carried forward also?
If you copy (rather than Copy followed by PasteSpecial) a cell, the data validation will copy with it:
the code:
Sub KopyKat()
Dim J4 As Range, K5 As Range
Set J4 = Range("J4")
Set K5 = Range("K5")
J4.Copy K5
End Sub
the result:
So I'm trying to run a column through a table in Excel using VBA. I then want to copy the result and paste in another column. I've gotten it to work for one cell, however, when I try to loop the code, it just pastes the same thing in every cell in the range I want it to paste in. How do I make it so that when it loops, it only pastes in the single cell vs. the entire range? My code is below.
Sub Test1()
'
' Test1 Macro
'
'
Dim rng As Range, cell As Range
Set rng = Range("C16:C20")
For Each cell In rng
Dim rng2 As Range, cell2 As Range
Set rng2 = Range("G16:G20")
For Each cell2 In rng2
cell.Select
Selection.Copy
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D12").Select
Application.CutCopyMode = False
Selection.Copy
rng2.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Tranpose:=False
'ActiveCell.Offset(1, 0).Select
Next cell2
Next cell
End Sub
Thanks!
Guessing you want something like this:
Sub Test1()
Dim rng As Range, cell As Range, ws As Worksheet
Set ws = ActiveSheet
Set rng = ws.Range("C16:C20")
For Each cell In rng.Cells
ws.Range("B4").value = cell.Value
cell.offset(0, 4).value = ws.Range("D12").Value 'populate in Col G
Next cell
End Sub
Note there's typically no need to select/activate anything in excel (though the macro recorder does that a lot). Worth reviewing this: How to avoid using Select in Excel VBA
Likewise if you need to transfer values between cells you can do that directly without copy/paste.
I'm new to VBA. I use a one column array for the variable data. Starting at the first cell (A1) I want to copy the text value in A1, paste to Sheet2,in A5, go back to the array and do it all over again, until I get to an empty cell. Easy right?
Here is the code that I have, I can not copy the value and paste it.
Thank you, for your suggestions!!!
Sub copylist()
' copylist Macro
Worksheets("ID nbr").Select
Range("B3").Select
For Each c In Worksheets("ID nbr").Range("B3:B20").Cells
If c.Value <> "" Then
Sheets("ID nbr").Select
Dim rgCopy As Range
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("B4:G4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Findings").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
Next
End Sub
You have made a great attempt using the macro recorder. Now let's clean it up:
I moved all the sheets into variables to limit the amount of typing.
I removed all the .Select and .Activate, these just slow the code down and if referenced properly they are not needed.
When only values are wanted, then assigning them directly is quicker than using the clipboard. We can do this as one block of cells.
I used a counter to move down one row on the target sheet for every row found in the original sheet.
The code:
Sub copylist()
Dim ows As Worksheet
Dim tws As Worksheet
Dim c As Range
Dim i As Long
Set ows = Sheets("ID nbr") 'Original sheet
Set tws = Sheets("Findings") 'Target sheet
i = 4 'this is the first row in the target sheet
With ows
For Each c In .Range("B3:B20").Cells
If c.Value <> "" Then
tws.Range(tws.Cells(i, "B"), tws.Cells(i, "G")).Value = .Range(.Cells(c.Row, "B"), .Cells(c.Row, "G")).Value
i = i + 1
End If
Next c
End With
End Sub
I have researched this issue on several different sites with no clear way to do what I want:
I have a spreadsheet with 68 pairs of columns from 'B' to 'EG' and one leading column of data in 'A'.
I want create a new worksheet and name it for the header for the first column of each pair of columns, then copy the column of data in 'A' and the pair of columns into the new worksheet, and do the same for each succeeding pair of columns. I can create the new worksheets from the existing spreadsheet data, but not sure how to name the new worksheets to match the header field.
The following code will create a new worksheet and copy the data, but it won't name the worksheet, and I have to create 68 separate blocks for each succeeding pair of columns! Can anyone suggest a mod to the code to loop through the columns and do what I want? Generated code is below! And any real help would be very much appreciated.
Thanks Mike
Code:
Sub testcopy()
testcopy Macro
Keyboard Shortcut: Ctrl+f
Range("A5:A17,B5:B17,C5:C17").Select
Range("C5").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
Range("A5:A17,D5:D17,E5:E17").Select
Range("E5").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
.
.
.
End Sub
Something like this:
Sub testcopy()
Dim shtSrc As Worksheet, sht As Worksheet
Dim i As Long, rngA As Range, rngTwo As Range
Set rngA = ActiveSheet.Range("A5:A17")
Set rngTwo = ActiveSheet.Range("B5:C17")
For i = 1 To 68
Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
sht.Name = rngTwo.Cells(1).Value
Application.Union(rngA, rngTwo).Copy
sht.Range("A5").PasteSpecial Paste:=xlPasteValues
Set rngTwo = rngTwo.Offset(0, 2)
Next i
End Sub