my questing is about trying to copy and paste 4 rows (4-7) under each row for the entire sheet, maybe using loop. I have pasted the copied rows under row 8 & 13 as an example (I would like to be able to do that for the remaining sheet until the rows are empty). Your expertise is greatly appreciated.
enter image description here
To implement:
Create a second sheet (in my code, referenced as Sheet2)
Paste the rows on this sheet that are to be inserted on the first sheet
Run Macro
Option Explicit
Sub EnterRows()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update
Dim i As Long, LR As Long, myRange As Range
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set myRange = ThisWorkbook.Sheets("Sheet2").Range("1:4")
Application.ScreenUpdating = False
For i = LR To 2 Step -1
myRange.Copy
ws.Range("A" & i + 1).Insert xlDown
Next i
Application.ScreenUpdating = True
End Sub
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 am working on one scenario where I have two sheets. Sheet1 is the master sheet and sheet2 which I am creating.
Column1 of Sheet1 is Object which has duplicate objects as well. So, what I have done is I have created a macro which will produce the unique Objects and will paste it in sheet2.
Now, from Sheet2, each of the objects should be matched with Sheet1 column1 and based on the matching results, it should also count the corresponding entries from other columns in sheet1 to sheet2.
Below are the snapshots of my two sheets
Sheet1
Sheet2
here is my macro code which will first copy and paste the unique objects from sheet1 to sheet2 Column1.
Sub UniqueObj()
Dim Sh1 As Worksheet
Dim Rng As Range
Dim Sh2 As Worksheet
Set Sh1 = Worksheets("Sheet1")
Set Rng = Sh1.Range("A1:A" & Sh1.Range("A65536").End(xlUp).Row)
Set Sh2 = Worksheets("Sheet1")
Rng.Cells(1, 1).Copy Sh2.Cells(1, 1)
Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sh2.Range("A1"), Unique:=True
End Sub
But, I am unable to move forward from there. I am pretty new and any help would be very greatful.
Thanks
If I'm understanding what you want correctly, you're just counting matching columns from Sheet1 where the value in the corresponding column isn't blank? If so this should do the trick.
Option Explicit
Sub GetStuffFromSheet1()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim x As Long
'turn on error handling
On Error GoTo error_handler
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
'determine last row with data in sheet 1
lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
'determine last row with data in sheet 2
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
'define columns in sheet 1
Const objCol1 As Long = 1
Const rProdCol1 As Long = 3
Const keysCol1 As Long = 4
Const addKeysCol1 As Long = 5
'define columns in sheet 2
Const objCol2 As Long = 1
Const rProdCol2 As Long = 2
Const keysCol2 As Long = 3
Const addKeysCol2 As Long = 4
'turn off screen updating + calculation for speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'loop through all rows of sheet 2
For x = 2 To lastRow2
'formula counts # of cells with matching obj where value isn't blank
ws2.Cells(x, rProdCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(rProdCol1), "<>" & "")
ws2.Cells(x, keysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(keysCol1), "<>" & "")
ws2.Cells(x, addKeysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(addKeysCol1), "<>" & "")
Next x
'turn screen updating + calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
error_handler:
'display error message
MsgBox "Error # " & Err.Number & " - " & Err.Description, vbCritical, "Error"
'turn screen updating + calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End Sub
In case a non VBA solution works for you, you can resume your data with a Pivot Table, take field Object into rows section and rest of fields into values section (choose Count)
This returns the exact output you are looking for. Easy to update and easy to create.
In case you want a VBA solution, because your design is tabular and you are counting values, you can use CONSOLIDATE:
Consolidate data in multiple worksheets
'change K1 with cell where to paste data.
Range("K1").Consolidate Range("A1").CurrentRegion.Address(True, True, xlR1C1, True), xlCount, True, True, False
'we delete column relation type and column value. This columns depends on where you paste data, in this case, K1
Range("L:L,P:P").Delete Shift:=xlToLeft
After executing code i get this:
Hope this helps
I have two questions
How to combine data using two of the cells from workbookA and copy to workbookB on the same cell?
How do I start using for loop to copy it until the last row/column?
I have no clue on how to combine the data and I do not know where to place the variable inside the code for it to loop until its last column.
Dim Tlastrow As Integer
Tlastrow = Cells(1, Columns.Count).End(xlToLeft).Column
For r = 1 To Tlastrow
Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112").Range("F3:G3").Copy _
Workbooks("Output.xls").Worksheets("Sheet1").Range("I3")
Next
Try this:
Option Explicit
Sub Paste()
Dim wsInput As Worksheet, wsOutput As Worksheet, LastRow As Long, C As Range
Set wsInput = Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112")
Set wsOutput = Workbooks("Output.xls").Worksheets("Sheet1")
With wsInput
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row 'Last Row with data
For Each C In .Range("F3:F" & LastRow) 'loop for every row with data
wsOutput.Cells(C.Row, "I").Value = C & " " & C.Offset(0, 1)
Next C
End With
End Sub
This code is assuming you want to paste every row from your input workbook to the output workbook on the same rows, but merging F and G columns. It's just pasting the values, not formulas or formats.
I have the following script copying a range "F30:F37", "G30:G37" from Sheet 1. I am trying to select both ranges into Sheet2 starting with ROW G101. However, only Sheet 1 "G30:G37" data copies into Sheet 2, ROW G101. What could be the issue, would you be able to simplify my data pull? Listed below, Macro:
Dim LastRow As Long
Dim SHEET2 As Worksheet
Set Results = Sheets("SHEET2")
LastRow = Results.Cells(Results.Rows.Count, "Z").End(xlUp).Row
Range("F30:F37").Copy
Results.Range("G" & LastRow + 101).PasteSpecial xlPasteValues
Range("G30:G37").Copy
Results.Range("G" & LastRow + 101).PasteSpecial xlPasteValues
Application.DataEntryMode = False
End Sub
This is how column with rows display, please note, row G has no header:
This would be my result:
My result would look like the second image, sheet 2
First off, Results is a variable that should be in your Dim statement, not "Sheet2". Secondly, you are pasting over the first paste. If you want row 101 for the first, paste in row 101. Then find the last row and paste the info below. And lastly, you want Application.CutCopyMode to take you out of the copy/paste.
Sub CopyData()
Dim LastRow As Long
Dim Results As Worksheet
Set Results = Sheets("SHEET2")
Range("F30:F37").Copy
Results.Range("G101").PasteSpecial xlPasteValues
LastRow = Results.Cells(Results.Rows.Count, "G").End(xlUp).Row
Range("G30:G37").Copy
Results.Range("G" & LastRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub
I need to copy all the text values from Column F on +10 sheets and place them in a single Column on an aggregate sheet. I do not need to perform any computation on the data, just copy the text values derived from formulas. For example:
Sheet1 Col F:
1
2
3
Sheet2 Col F:
4
5
6
I would like "Master" Col A be:
1
2
3
...
6
This code gets me mostly there, but I need the Range to vary. For instance, not every sheet has 3 rows of data, but I want them to be copied directly after each other.
Sub MM1()
Dim ws As Worksheet, lr As Long
lr = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row + 1
For Each ws In Worksheets
If ws.Name <> "Master" Then
ws.Range("F1:G15").Copy
Sheets("Master").Range("A" & lr).PasteSpecial xlPasteValues
lr = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row + 1
End If
Next ws
End Sub
EDIT: Every sheet DOES have the same number of rows with a formula in them, but the Values vary from sheet to sheet. So I need some check that looks for a "" Value as the "last row" then move to the next sheet.
First of all, you can use the same logic to get the last row in the column "F" in each datasheet instead of hard-coding 3 rows usingrange.end(xlUp).Row method.
2nd I don't like the copy-paste method. it is slow and is very bothering you always calculate new insertion point and paste. You can utilize array in VBA to realize this functionality. And work with Array is very straightforward and fast.
Below is the code you can grab and use.
Sub MM1()
Application.ScreenUpdating = False
'Loop through worksheets, put the values in column F into arr array
Dim arr(1 To 10000), cnt As Integer, i As Integer
cnt = 0
For Each ws In Worksheets
If ws.Name <> "Master" Then
For i = 1 To ws.Cells(Rows.Count, "F").End(xlUp).Row
cnt = cnt + 1
arr(cnt) = ws.Cells(i, "F").Value
Next i
End If
Next ws
'Loop through arr array, populate value into Master sheet, column A
For i = 1 To cnt
ThisWorkbook.Sheets("Master").Cells(i, "A") = arr(i)
Next i
Application.ScreenUpdating = True
End Sub
only small changes and its working good :)
1. I changed the Master to Sheet5 => you can use your sheet name.
2. Added a new variable in loop to identify the range for each sheet to be copied.
3. Change the method to paste the copied data to destination.
Sub MM1()
Dim ws As Worksheet, lr As Long
lr = Sheets("Sheet5").Cells(Rows.Count, "A").End(xlUp).Row + 1
For Each ws In Worksheets
If ws.Name <> "Sheet5" Then
Dim currentRange As Long
currentRange = ws.Cells(Rows.Count, "A").End(xlUp).Row
ws.Range("A1:A" & currentRange).Copy Destination:=Sheets("Sheet5").Range("A" & lr)
lr = Sheets("Sheet5").Cells(Rows.Count, "A").End(xlUp).Row + 1
End If
Next ws
End Sub
let me know if this works for you or not ?
I tried to keep your code as intact as possible. Here is one way to make it work (with as much preservation of your code as possible). There are still minor "touch ups" you would need to do (eg your "Master" sheet would have a blank row).
Sub MM1()
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "Master" Then
ws.Range(ws.Range("F1"), ws.Range("F1").End(xlDown)).Copy
Sheets("Master").Range("A65535").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If
Next ws
End Sub