My question is of two parts:
Part 1:
I have two worksheets. In one worksheet named "Equipment details" I have a set of values in column A, rows 13 to 1000. I want to copy each of these values, namely A13, A14, A15 and so forth in to another worksheet named "Worksheet(2)" starting at cell A2. However, the trick is A13 from the first worksheet needs to be copied into A2 of the second worksheet, A14 to A8, A15 to A14 and so on in increments of 6 each time.
This part was sorted out earlier.
Part 2:
The new values copied over from "Equipment details" to "Worksheet(2)" now need to copy down their values to the next 6 rows and so on. For example, the Value in Cell A2 in "Worksheet(2)" needs to be copied down to rows A3 to A8. Then the next value in A9 that was copied over from "Equipment details" in Part 1 needs to be copied down from A10 to A15 and so on. This is my code and it works well in copying from Row A3 toA8 but then it does not jump to row A10 and instead keeps overwriting the values in rows A3 to A8.
Sub CopyDataInBetweenCells()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim destws As Worksheet
Set destws = wb.Worksheets("Worksheet (2)")
Dim RowNo2 As Long
Dim RowNo3 As Long
For RowNo2 = 1 To 2000
For RowNo3 = 1 To 6
destws.Cells(RowNo2 * 7 - 5, 1).Copy Destination:=destws.Cells(RowNo3 * 1 + 2, 1)
Next RowNo3
Next RowNo2
End Sub
Calculate the destination range:
Sub CopyData2()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim srcws As Worksheet
Set srcws = wb.Worksheets("Equipment details")
Dim destws As Worksheet
Set destws = wb.Worksheets("Worksheet (2)")
Dim RowNo As Long
For RowNo = 0 To 987
srcws.Range("A" & RowNo + 13).Copy Destination:=destws.Range("A" & RowNo * 7 + 2 & ":A" & RowNo * 7 + 8)
Next RowNo
End Sub
Use Resize
Sub CopyDataInBetweenCells()
Dim wb As Workbook, destws As Worksheet
Set destws = wb.Worksheets("Worksheet (2)")
Dim RowNo As Long, n As Long
With destws
For n = 1 To 2000
RowNo = 2 + (n - 1) * 7
.Cells(RowNo + 1, 1).Resize(6) = .Cells(RowNo, 1)
Next
End With
End Sub
Related
(not in a range, not adjacent columns)
(in given order)
I have many rows on Sheet1. I would like to copy some columns of a row (not the entire row and not a range of columns) to Sheet2 (to the first empty row of Sheet2) if a cell satisfies a condition (the cell in the current row and A column has a value of y)
I would like to copy not the entire row from Sheet1 only the row with those columns that are given on Sheet3 (Column A), and the new column number (on Sheet2) is also given on Sheet3 (column B)
It would be simple if my task would be to copy the entire row, or the selected column would be in a range...but i would need to copy those columns that are specialized on Sheet3. I would be grateful for any help. Thanks in advance.
Sheet1 shows an example data sheet. The criteria is if Cells(Rows, 1).Value = "y"
Sheet2 shows the desired result.
Sheet3 shows the selected column number on Sheet1 and the new column number on Sheet2
Whilst this probably should be done using arrays more, here's some basic VBA code that loops the first sheet checking for "y" in the first column. When it finds it, it then loops the column mappings in the third sheet that have been saved into arrays to set the values on the second sheet:
Sub sTranasferData()
On Error GoTo E_Handle
Dim aOld() As Variant
Dim aNew() As Variant
Dim wsIn As Worksheet
Dim wsOut As Worksheet
Dim wsTrack As Worksheet
Dim lngLastRow As Long
Dim lngLoop1 As Long
Dim lngLoop2 As Long
Dim lngRow As Long
Dim lngTrack As Long
Set wsIn = Worksheets("Sheet1")
Set wsOut = Worksheets("Sheet2")
Set wsTrack = Worksheets("Sheet3")
lngLastRow = wsIn.Cells(wsIn.Rows.Count, "A").End(xlUp).Row
lngTrack = wsTrack.Cells(wsTrack.Rows.Count, "A").End(xlUp).Row
aOld() = wsTrack.Range("A2:A" & lngTrack).Value
aNew() = wsTrack.Range("B2:B" & lngTrack).Value
lngRow = 1
For lngLoop1 = 2 To lngLastRow
If wsIn.Cells(lngLoop1, 1) = "y" Then
For lngLoop2 = LBound(aOld) To UBound(aOld)
wsOut.Cells(lngRow, aNew(lngLoop2, 1)) = wsIn.Cells(lngLoop1, aOld(lngLoop2, 1))
Next lngLoop2
lngRow = lngRow + 1
End If
Next lngLoop1
sExit:
On Error Resume Next
Set wsIn = Nothing
Set wsOut = Nothing
Set wsTrack = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sTransferData", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards,
My current code creates 9 copies of a sheet called "MasterCalculator". It decides the amount of copies to be named by counting the number of cells filled in Row 1 (starting at column C) in the other sheet Called 'LLP Disc Sheet'. Each of the 9 sheets created are then named. Sheet 1's name comes from C1 in the 'LLP Disc Sheet', Sheet 2's name comes from D1 in the 'LLP Disc Sheet', Sheet 3's names comes from E1 in the 'LLP Disc Sheet', and so on.
Option Explicit
Public Sub NewSheets()
Dim shCol As Integer
Dim i As Integer
Dim ws As Worksheet
Dim sh As Worksheet
Set ws = Sheets("MasterCalculator")
Set sh = Sheets("LLP Disc Sheet")
Application.ScreenUpdating = 0
Application.EnableEvents = 0
shCol = 2
sh.Activate
For i = 2 To sh.Range("A1:Z1").Cells.SpecialCells(xlCellTypeConstants).Count
shCol = shCol + 1
Application.StatusBar = "Processing " & sh.Cells(1, shCol).Text & Format(i / sh.Range("A1:Z1").Cells.SpecialCells(xlCellTypeConstants).Count, " #0.0 %")
Select Case shCol
Case Is = 3
ws.Copy After:=sh
Case Else
ws.Copy After:=Sheets(sh.Cells(1, shCol - 1).Text)
End Select
ActiveSheet.Name = sh.Cells(1, shCol).Text
Application.CutCopyMode = False
Next i
sh.Activate
Application.StatusBar = 0
Application.EnableEvents = 1
Application.ScreenUpdating = 1
Application.CalculateFull
End Sub
So now that all the sheets are created and named... I now want to update the formulas in each since they're copies of the sheet called 'MasterCalculator'. There are 2 cells in each sheet I need to update - cell B1 and cell M4. Cell B1 contains the formula "=+'LLP Disc Sheet'!C1". The sheet that was created based on C1 in the 'LLP Disc Sheet' can keep this formula. However, the next sheet (sheet 2) that was created and named based off of D1 in the "LLP Disc Sheet" needs to be updated to "=+'LLP Disc Sheet'!D1". This goes on with the rest of the sheets. The next has to change to =+'LLP Disc Sheet'!E1 and so on. How do I create a code to replace that cell in each of the newly created sheet with an updated formula that only changes it to cell referenced one cell after in the 'LLP Disc Sheet'?
ActiveSheet.Range(“B1:M4”).Replace_
What: ="LLP Disc Sheet'!C1", Replacement:="LLP Disc Sheet'!D1”,_ ‘but I want it to continue to the next sheet to replace D1 with E1 and so on until all of the B1 cells match their sheet names (it also allow all the data to be filled in). All of these will be found in cell B1 in the MasterCalculator copies
What: ="LLP Disc Sheet'!$C$1:$C$", Replacement:=" LLP Disc Sheet'!$D$1:$D$”,_ ‘but I want it to continue to the next sheet to replace $D$1 with E$1$ and $D$ with $E$ and so on until all of the M4 cells are set to 0.
SearchOrder:=xlByRows, MatchCase:=True
Use formulaR1C1
Option Explicit
Public Sub NewSheets()
Dim wb As Workbook, ws As Worksheet, wsMaster As Worksheet
Dim iLastCol As Integer, iCol As Integer
Dim s As String, n As Integer
Set wb = ThisWorkbook
Set wsMaster = wb.Sheets("MasterCalculator")
Set ws = wb.Sheets("LLP Disc Sheet")
iLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
n = wb.Sheets.Count
For iCol = 3 To iLastCol
s = ws.Cells(1, iCol) ' sheet name
If Len(s) > 0 Then
wsMaster.Copy After:=Sheets(n)
n = n + 1
wb.Sheets(n).Name = s
wb.Sheets(n).Range("B1,M4").FormulaR1C1 = "='" & ws.Name & "'!R1C" & iCol
End If
Next
MsgBox iLastCol - 2 & " sheets added", vbInformation
End Sub
I want to use each value/string in a certain column (A1, A2, A3...) in worksheet 1 to search a certain range in worksheet 2 for that value/string alone and (!) with additional endings.
Example: Use in worksheet 1 A1 = K-1234 and search in a defined range in worksheet 2 for the string K-1234 and combinations of K-1234 with /x, /y, /z. Whenever you find such a combination copy the whole row from worksheet 2 into a new worksheet 3.
Using column A in worksheet 1:
worksheet 1
A
A1 = K-1234
A2 = Y-1234
A3 = RP-78
…
A1000 = Z/34-1
Searching in worksheet 2 in the range B1:E3 for A1, A1/x, A1/y and A1/z:
worksheet 2
A B C D E
GHJ A1/x 456 G5G F1-1
FF- A1 23-A TTR BV1
8/a A1/z bnR 34-1 bn/1
That's how worksheet 3 should look like after using A1 from worksheet 1 to search in worksheet 2:
worksheet 3
A B C D E
FF- A1 23-A TTR BV1
GHJ A1/x 456 G5G F1-1
8/a A1/z bnR 34-1 bn/1
or with A1 written out:
worksheet 3
A B C D E
FF- K-1234 23-A TTR BV1
GHJ K-1234/x 456 G5G F1-1
8/a K-1234/z bnR 34-1 bn/1
(A1/y doesn't exist)
Continue with A2, A2/x, A2/y and A2/z and so on till the end of the column (for example A1000).
Hope I could explain the problem sufficiently. I would be very thankful for any suggestion.
You could try:
Option Explicit
Sub CopyYes()
Dim i As Long, LastRow1 As Long, LastRow3 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim rngToSearch As Range, rngFound As Range
With ThisWorkbook
Set ws1 = .Worksheets("Sheet1")
Set ws2 = .Worksheets("Sheet2")
Set ws3 = .Worksheets("Sheet3")
End With
Set rngToSearch = ws2.Range("B1:E3")
With ws1
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow1
Set rngFound = rngToSearch.Find(.Range("A" & i).Value & "*", LookIn:=xlValues)
If Not rngFound Is Nothing Then
LastRow3 = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row
If LastRow3 = 1 And ws3.Range("A1").Value = "" Then
LastRow3 = 1
Else
LastRow3 = LastRow3 + 1
End If
ws2.Range("B" & rngFound.Row & ":E" & rngFound.Row).Copy
ws3.Range("A" & LastRow3).PasteSpecial Paste:=xlPasteValues
End If
Next i
End With
End Sub
I have problem,
I have e.g 180 rows in sheet, I want to choose randomly e.g 18 rows in range from A2 to the end of sheet except first because there will be title of columns, and paste it to new sheet,
The following will achieve what you are wanting, it will generate 18 random numbers between 2 and your last row with data, in your case row 180 and then copy that row into the next free row in Sheet2:
Sub foo()
Dim wsOriginal As Worksheet: Set wsOriginal = ThisWorkbook.Worksheets("Sheet1")
Dim wsDestination As Worksheet: Set wsDestination = ThisWorkbook.Worksheets("Sheet2")
'declare and set the worksheets you are working with, amend as required
Dim i As Long, LastRowOrig As Long, LastRowDest As Long
LastRowOrig = wsOriginal.Cells(wsOriginal.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A on your Sheet with data
For i = 1 To 18 'loop 18 times
RandNumber = Int((LastRowOrig - 2 + 1) * Rnd + 2)
'generate a random number between 2 and 180 (Last Row)
LastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
'get the last row with data on Destination sheet and offset by one (i.e. next free row)
wsOriginal.Rows(RandNumber).Copy 'copy the row
wsDestination.Rows(LastRowDest).PasteSpecial xlPasteAll 'paste the row
Next i
End Sub
UPDATE:
To reflect your comment and add a new workbook with the random rows in it, use the following code:
Sub foo()
Dim wsOriginal As Worksheet: Set wsOriginal = ThisWorkbook.Worksheets("Sheet1")
Dim wsDestination As Worksheet
Dim i As Long, LastRowOrig As Long, LastRowDest As Long
Set NewWorkbook = Workbooks.Add 'create a new workbook
With NewWorkbook
.Title = "Random Rows" 'You can modify this value.
.SaveAs Filename:="C:\Users\doneby\Desktop\RandomGeneratedRows.xlsx"
'amend the line above to the path you and name of the file you want to create
End With
Set wsDestination = NewWorkbook.Worksheets("Sheet1") 'specify the Sheet of the new workbook
'declare and set the worksheets you are working with, amend as required
LastRowOrig = wsOriginal.Cells(wsOriginal.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A on your Sheet with data
For i = 1 To 18 'loop 18 times
RandNumber = Int((LastRowOrig - 2 + 1) * Rnd + 2)
'generate a random number between 2 and 180 (Last Row)
LastRowDest = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
'get the last row with data on Destination sheet and offset by one (i.e. next free row)
wsOriginal.Rows(RandNumber).Copy 'copy the row
wsDestination.Rows(LastRowDest).PasteSpecial xlPasteAll 'paste the row
Next i
NewWorkbook.Close SaveChanges:=True
'close and save the new workbook
End Sub
I would like to copy the following four formulas and paste it in the adjacent four columns with the column reference changing by four everytime. What i mean is copy F4:I4 and paste to J4:M4,N4:Q4...with the "F" cahnging to a "J", then "N", then "Q" and so on until the end of the columns in the sheet.
=IF(AND(F2>=$C$4,F2<=$D$4),TRUE, FALSE)
=IF(AND((F2+6)>=$C$4,(F2+6)<=$D$4),TRUE,FALSE)
=IF(AND((F2+12)>=$C$4,(F2+12)<=$D$4),TRUE,FALSE)
=IF(AND((F2+18)>=$C$4,(F2+18)<=$D$4),TRUE,FALSE)
Am I able to some way loop this going across each column, and after the fourth add four to the numerical value of the cell reference? so instead of F2 and J2 I have Col_ID, Col_ID+4...Not sure how to write this in VBA. Any help would be greatly appreciated.
I used this to merge every four cells above to make the "labels", i'm thinking I can re-use this but not sure how.
Dim Rng As Range
Dim ws As Worksheet
Dim R1 As Long, C1 As Long
Dim R2 As Long, C2 As Long
Dim lastCol As Long
Set ws = ThisWorkbook.Sheets("Dashboard")
R1 = 3: C1 = 6
R2 = 3: C2 = C1 + 3
lastCol = 1
While lastCol < 256
With ws
Set Rng = .Range(.Cells(R1, C1), .Cells(R2, C2))
Application.DisplayAlerts = False
Rng.Merge
Application.DisplayAlerts = True
C1 = C2 + 1
C2 = C1 + 3
lastCol = lastCol + 1
End With
Wend
This will copy a source range to as many groups of four columns as you specify with NumberOfCopies. You didn't say what range you are copying from, so I assumed G3:J3:
Sub CopyCols()
Dim rngSource As Excel.Range
Dim rngTarget As Excel.Range
Dim NumberOfCopies As Long
NumberOfCopies = 12
With ActiveSheet
Set rngSource = .Range("G3:J3")
Set rngTarget = .Range("K3").Resize(rngSource.Rows.Count, NumberOfCopies * 4)
rngSource.Copy Destination:=rngTarget
End With
End Sub