I'm new to this forum. and I have some problem.
I want to copy a list from sheet "Import Data" to sheet "June" but each list I want to skip few rows.
I've come out with some code but it didn't work. When I run the code individually, it skips the second For loop.
please help me.
Sub copypasteskip()
Dim sheet1 As Variant
Dim sheet2 As Variant
Dim endnumber As Integer
Dim finalrow As Variant
Dim i As Integer
Dim r As Integer
Set sheet1 = ThisWorkbook.Worksheets("June")
Set sheet2 = ThisWorkbook.Worksheets("ImportData")
endnumber = sheet1.Cells(Rows.Count, "A").End(xlUp).Row
finalrow = sheet2.Cells(Rows.Count, "D").End(xlUp).Row
For r = 11 To endnumber 'the list should paste starts at rows 11, cells "A"
For i = 14 To finalrow 'the list need to be copy starts at rows 14,cells "D"
sheet2.Cells(i, "D").End(xlDown).Copy
sheet1.Cells(r, "A").PasteSpecial xlPasteValues
Next i
r = r + 7 'need to skips 7 rows for each list
Next r
End sub
If your second For loop doesn’t run that means that the value of finalrow is less than 11. Try using the locals Windows or hovering your mouse over the name to see its value. You could also insert a debug.print(finalrow)
just before the first loop.
Sub copypasteskip()
Dim sheet1 As Variant
Dim sheet2 As Variant
Dim endnumber As Integer
Dim finalrow As Variant
Dim i As Integer
Dim r As Integer
Set sheet1 = ThisWorkbook.Worksheets("June")
Set sheet2 = ThisWorkbook.Worksheets("ImportData")
endnumber = sheet1.Cells(Rows.Count, 1).End(xlUp).Row
finalrow = sheet2.Cells(Rows.Count, 4).End(xlUp).Row
For r = 11 To endnumber Step 7 'the list should paste starts at rows 11, column 1
For i = 14 To finalrow 'the list need to be copy starts at rows 14,column 4
sheet1.Cells(r, 1) = sheet2.Cells(i, 4)
Next i
Next r
End sub
Related
Would anyone will be able to help me with this script please?
As it stand, this current macro separate the data once the value/text have changes and insert new row but I just cannot work it out how to include the headers once the row have been inserted.
Sub Insert Row()
Dim ws As Worksheet
Dim lr As Long
Dim i As Long
Set ws = Worksheets("Sheet1") 'the sheet with the data
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'last row with data in Column A
For i = lr - 1 To 2 Step -1
If ws.Range("A" & i).Value <> ws.Range("A" & i + 1).Value Then ws.Range("A" & i + 1).EntireRow.Insert
Next i
End Sub
Thank you in advanced.
Duplicate Headers
A Quick Fix
Sub InsertHeaders()
Const FIRST_ROW As Long = 1
Const EMPTY_ROWS As Long = 1
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim r As Long
For r = LastRow To FIRST_ROW + 2 Step -1
With ws.Cells(r, "A")
If .Value <> .Offset(-1).Value Then
.EntireRow.Resize(EMPTY_ROWS + 1).Insert
ws.Rows(1).Copy ws.Rows(.Row - 1)
End If
End With
Next r
End Sub
Please ignore my comment, as I just realize that it will be a different result if in column A there is a cell with the same value.
Example Data :
Expected result after running the sub :
Sub test()
Dim rgHdr As Range: Dim rgData As Range: Dim cell As Range
Dim i As Integer: Dim arr: Dim ins As Integer:dim sh as worksheet
Set sh = Sheets("Sheet1") 'change if needed
ins = 3 'change if needed
With sh
.Range("A1").EntireRow.Resize(ins).Insert Shift:=xlDown
Set rgHdr = .Range("A1").EntireRow.Resize(1 + ins)
Set rgData = .Range("K" & 2 + ins, .Range("K" & Rows.Count).End(xlUp))
End With
Set arr = CreateObject("scripting.dictionary")
For Each cell In rgData: arr.Item(cell.Value) = 1: Next
For i = 1 To arr.Count - 1
rgHdr.Copy
sh.Cells(rgData.Find(arr.Keys()(i), _
after:=rgData.End(xlDown)).Row, 1).Insert Shift:=xlDown
Next
sh.Range("A1").EntireRow.Resize(ins).Delete
End Sub
sh = the sheets where the data is.
ins = skip how many blank rows.
The code use "insert copied cells" method, so it make three blank rows (the value of ins) before the header, then set the first three rows as rgHdr, set the rgData from K2 down to the last row with value.
arr = unique value in column K.
then it loop to each element in arr, get the first row occurence of the found cell which value is the looped element in arr, insert the copied rgHdr to that row.
Then finally it delete those three (ins value is 3) additional blank rows.
I want to loop through a lot of data—5,734 rows to be exact. This is what I want to do for all rows:
Private Sub CommandButton1_Click()
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).row
Range("A2:A14").Copy Range("D2:D14")
("B2:B14").Copy Range("D15:D27")
Range("C2:C14").Copy Range("D28:D40")
Assuming that your data looks like this (colour to show more easily the groups):
The following code will paste each group (yellow, green) to the "Result" column.
Code:
Option Explicit
Sub copy_paste()
Dim lrow As Long
Dim i As Long
Dim j As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the name of the sheet
lrow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'Find the last row in column A
For i = 2 To lrow Step 13 'Loop every group (group of 13 rows) in column A
For j = 1 To 13 Step 13 'For each group, copy and paste
ws.Cells(i, "A").Resize(13).Copy ws.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) 'Copy the group and paste it to the column D. Offset by one to not overwrite the last row
ws.Cells(i, "B").Resize(13).Copy ws.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
ws.Cells(i, "C").Resize(13).Copy ws.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0)
Next j
Next i
End Sub
Result:
I have a workbook with a series of sheets that I need to run a code to resolve the data.
I have one worksheet with a list of "codes" and another sheet that has cells that will include a string of codes.
I am trying to create a macro that allows me to reference a code in sheet1 A1, and then look through B:B in sheet2 and copy the row if the code appears in the string
I am a novice VBA user and have tried googling a few things and I'm not having any luck.
Edit:
I have managed to get something that does copy the data through, but there seems to be an issue in the For loop as all lines are copied in, not just the lines that match. Code below.
Private Sub CommandButton1_Click()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("MASTER LIST").UsedRange.Rows.Count
J = Worksheets("VALIDATED LIST").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("VALIDATED LIST").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("MASTER LIST").Range("E1:E" & I)
On Error Resume Next
Application.ScreenUpdating = True
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = InStr(Worksheets("MASTER LIST").Range("E1:E" & I).Value, Worksheets("TRANSPOSED DATA NO SPACES").Range("B1:B" & J)) > 1 Then
xRg(K).EntireRow.Copy Destination:=Worksheets("VALIDATED LIST").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Further Edit:
I want to be able to use the list of feature codes and look them up in the master list.
If the VBA code finds the feature code in the strings in the master list, then I need to copy the row and paste it into a blank sheet that will be called validated list.
Sub look_up_copy()
Dim last_row As Integer
Dim cell As Range
Dim Cells As Range
last_row = ThisWorkbook.Worksheets(2).Cells(ThisWorkbook.Worksheets(2).Rows.Count, "B").End(xlUp).Row
Set Cells = ThisWorkbook.Worksheets(2).Range("B1:B" & last_row)
For Each cell In Cells:
If cell.Value = ThisWorkbook.Worksheets(1).Range("A1").Value Then
cell.EntireRow.Copy
End If
Next cell
End Sub
You didn't say anything about wanting to paste, but if you do then just insert it after the copy line.
this should work, just remove duplicates on sheet3 after running. This is a double loop in which, for each cell in column B of sheet 2, the macro will check all values from sheet1 Column A. You will see duplicate lines in the end, but it doesn't matter right? all you need is remove dupes
Sub IvanAceRows()
Dim cell2 As Range, cells2 As Range, cell1 As Range, cells1 As Range
Dim lastrow2 As Long, lastrow1 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Long, ii As Long, iii As Long
Set ws1 = Worksheets("USAGE CODES")
Set ws2 = Worksheets("MASTER LIST")
Set ws3 = Worksheets("VALIDATED LIST")
lastrow1 = ws1.cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = ws2.cells(Rows.Count, 2).End(xlUp).Row
Set cells1 = ws1.Range("A1:A" & lastrow1)
Set cells2 = ws2.Range("B1:B" & lastrow2)
iii = 1
For ii = 1 To lastrow2
For i = 1 To lastrow1
If InStr(1, ws2.cells(ii, 2), ws1.cells(i, 1)) <> 0 Then
ws2.cells(ii, 2).EntireRow.Copy
ws3.Activate
ws3.cells(iii, 1).Select
Selection.PasteSpecial
iii = iii + 1
End If
Next i
Next ii
End Sub
Without seeing your spreadsheet, I assumed all of your 'codes' are listed in Column A in sheet1, and all of those code strings are also in sheet2 in column B. my code allows u to find each string from sheet1 in Column B of sheet2. Once found, it will be pasted into Sheet3 starting from the 2nd row.
Sub IvanfindsRow()
Dim i As Long
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim Code As String
Dim search As Range
lastrow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Sheet3").Range("A1").Select
For i = 1 To lastrow1
Code = Worksheets("Sheet1").Cells(i, 1).Value
Set search = Worksheets("Sheet2").Range("B1:B22").Find(what:=Code, lookat:=xlWhole)
If Not search Is Nothing Then
search.EntireRow.Copy
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial
Else 'do nothing
End If
Next i
Application.CutCopyMode = False
End Sub
I am not a programmer by trade but I am trying to automate a small portion of a report I use every day out of curiosity and self interest. Basically, we receive and manually enter contact information (name, e-mail, phone number, etc.) and mark select groups that a person is interested in joining. We then copy and paste that contact information entered into a different sheet for each group.
I want to have a macro that checks the specific columns for each interest group for a "x" and if it finds that value copy and paste the contact information collected to the specific interest groups worksheet. People are able to select multiple interest groups and their contact information is added to each separate interest group spreadsheet.
Report columns look as follows:
Group 1 Group 2 Group 3 Name Organization Phone E-mail Notes
Row Contact Information looks similar to:
x x John ABC Inc. 000-000-0000 john.smith#fake.com Call me ASAP!
The macro checks the column I have marked interest in Group 1 in and if it finds "x" then it copies the full range to the Group 1 worksheet.
I want it to be able to check multiple columns (i.e. Group 1, 2, 3) for "x" and then copy and paste the information to the right of those columns to the appropriate sheet for the group. If they have interest in multiple groups, their contact info should be copied to each specific worksheet.\
Do I need to have separate counters for each group worksheet and is there a way to write a if then statement that checks for x in each of the columns and then runs the appropriate code to copy and paste into that group?
Sub Update()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target1 As Worksheet
Dim Target2 As Worksheet
Dim Target3 As Worksheet
Set Source = ActiveWorkbook.Worksheets("Interest Group Tracking")
Set Target1 = ActiveWorkbook.Worksheets("Group 1")
j = 1 'Start copying to row 1 in target sheet
For Each c In Source.Range("A1:A1000") 'not sure if there is a way to not set a limit for the range
If c = "x" Then
Source.Rows(c.Row).Copy Target1.Rows(j + 1)
j = j + 1
End If
Next c
End Sub
No errors besides the occasional syntax but don't really know how to structure the loop for checking for each group. I am continuing to research and test things I find and will update if I need to.
See if this helps... I've added comments in the code, but please feel free to ask any other questions:
Sub Update()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim Source As Worksheet: Set Source = wb.Worksheets("Interest Group Tracking")
Dim Target As Worksheet
Dim R As Long, C As Long, lRowSrc As Long, lRowDst As Long
With Source
lRowSrc = .Cells(.Rows.Count, 1).End(xlUp).Row 'get the last row in your source sheet
For R = 1 To lRowSrc 'Loop through all rows in the source
For C = 1 To 3 'Loop through the 3 columns in the source
If .Cells(R, C) = "x" Then
Set Target = wb.Worksheets("Group " & C) 'Assuming all groups have the same names, Group 1, Group 2, etc
lRowDst = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row + 1 'get last row + 1 in the target sheet
.Rows(R).Copy Target.Rows(lRowDst)
End If
Next C
Next R
End With
End Sub
EDIT: additional sample
Sub Update()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim Source As Worksheet: Set Source = wb.Worksheets("Interest Group Tracking")
Dim Target As Worksheet
Dim shNames() As String: shNames = Split("ABC Group,Voter Accesibility,Animal Rights Activism", ",") 'Add sheet names here in the order of the groups
Dim R As Long, C As Long, lRowSrc As Long, lColSrc As Long, lRowDst As Long
With Source
lRowSrc = .Cells(.Rows.Count, 1).End(xlUp).Row 'get the last row in your source sheet
For R = 1 To lRowSrc 'Loop through all rows in the source
For C = 1 To 3 'Loop through the 3 columns in the source
If .Cells(R, C) = "x" Then
Set Target = wb.Worksheets(shNames(C - 1)) 'shNames array starts at 0
lRowDst = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row + 1 'get last row + 1 in the target sheet
Target.Range(Target.Cells(lRowDst, 1), Target.Cells(lRowDst, 10 - C + 1)) = .Range(.Cells(R, C), .Cells(R, 10)).Value 'allocate the values
End If
Next C
Next R
End With
End Sub
Another way of doing it.
Option Explicit
Sub CopyData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Dim destWS As Worksheet
Dim CopyRange As Variant
Dim i As Long, j As Long
Dim srcLRow As Long, destLRow As Long
Dim LCol As Long
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.ActiveSheet
srcLRow = srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Row
'loop through column 1 to 3
For i = 1 To 3
For j = 2 To srcLRow
'loop through rows
If srcWS.Cells(j, i).value = "x" Then
Set destWS = srcWB.Sheets("Sheet" & i)
destLRow = destWS.Cells(destWS.Rows.Count, "A").End(xlUp).Row
LCol = srcWS.Cells(j, srcWS.Columns.Count).End(xlToLeft).Column 'if you need to grab last used column
' Copy data
Set CopyRange = srcWS.Range(Cells(j, 1), Cells(j, LCol))
CopyRange.Copy
' paste data from one sht to another
destWS.Cells(destLRow + 1, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=False
Application.CutCopyMode = False
End If
Next j
Next i
MsgBox "Process completed!", vbInformation
End Sub
I changed the main piece of logic at the end but this should work. Instead of copy and pasting, I just made the range in the group1 sheet equal to the row's range. I also use the last used row.
Sub Update()
Dim c As Range
Dim j As Integer
Dim k As Integer
Dim Source As Worksheet
Dim Target1 As Worksheet
Dim Target2 As Worksheet
Dim Target3 As Worksheet
Dim curSheet As Worksheet
Dim lastRow, lastRow1, lastRow2, lastRow3, lastCol As Long
Dim group1, group2, group3, curGroup As Long
Set Source = ActiveWorkbook.Worksheets("Interest Group Tracking")
Set Target1 = ActiveWorkbook.Worksheets("Group 1")
Set Target2 = ActiveWorkbook.Worksheets("Group 2")
Set Target3 = ActiveWorkbook.Worksheets("Group 3")
j = 1
group1 = 1
group2 = 1
group3 = 1
With Source
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
lastRow2 = .Cells(.Rows.Count, 2).End(xlUp).Row
lastRow3 = .Cells(.Rows.Count, 3).End(xlUp).Row
If lastRow1 > lastRow2 And lastRow1 > lastRow3 Then
lastRow = lastRow1
End If
If lastRow2 > lastRow1 And lastRow2 > lastRow3 Then
lastRow = lastRow2
End If
If lastRow3 > lastRow1 And lastRow3 > lastRow2 Then
lastRow = lastRow3
End If
For j = 1 To lastRow
For k = 1 To 3
If .Cells(j, k) = "x" Then
Set curSheet = ActiveWorkbook.Sheets("Group" & " " & k)
If k = 1 Then
curGroup = group1
ElseIf k = 2 Then
curGroup = group2
ElseIf k = 3 Then
curGroup = group3
Else
GoTo line1
End If
curSheet.Range(curSheet.Cells(curGroup, 1), curSheet.Cells(curGroup, lastCol)).Value = .Range(.Cells(j, 1), .Cells(j, lastCol)).Value
End If
If k = 1 Then
group1 = group1 + 1
ElseIf k = 2 Then
group2 = group2 + 1
ElseIf k = 3 Then
group3 = group3 + 1
End If
line1:
Next k
Next j
End With
End Sub
hoping someone is able to help me! I've been stuck for some time... Thanks in advance!
In Workbook 1, if column D (starting row 19 and higher) in Sheet1 is equal to "SOW", then copy entire row to first available row (after row 19) in Sheet1 Workbook 2. Once copied continue scanning through items in column D for more instances of "SOW".
Background
- I am attempting to copy entire row as I have to copy the row from row A:NL
- There are around 175 rows which it needs to go though
Below are two codes that I have tried to no avail. They essentially do nothing, there are no errors.
Sub TEST2()
Dim LastRow As Long, i As Long, erow As Long
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 4).Value = "SOW" Then
Range(Cells(i, 1), Cells(i, 400)).Select.Copy
Workbooks.Open Filename:="Y:\Station Operations\Station Ops Shared\WEST VACATION CALENDAR 2019.xlsm"
Worksheets("SOW_2019").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If
Next i
End Sub
Sub TESTER()
Dim i As Long
Dim outRow As Long
Dim sourceWs As Worksheet, destWs As Worksheet
Set sourceWs = Workbooks("EAST VACATION CALENDAR 2019").Worksheets("SOE_2019")
Set destWs = Workbooks("WEST VACATION CALENDAR 2019").Worksheets("SOW_2019")
LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row
outRow = 1
For i = 19 To LastRow
If sourceWs.Cells(i, 4).Value = "SOW" Then
sourceWs.Rows(i).EntireRow.Copy destWs.Rows(outRow)
outRow = outRow + 1
Application.CutCopyMode = False
End If
Next i
End Sub
I'm going to assume we are running code in the East Calendar and outputting data to the West Calendar.
This allows me to explicitly name the workbooks and worksheets. Once I get a handle on my objects I can directly assign values to values without copy and paste. Destination = Source. I'm not sure if you wanted to start at row 19 or 2 so I chose 2 in order to look at more rows. Your two code examples are very different.
Sub TESTER()
Dim sourceWs As Worksheet
Set sourceWs = ThisWorkbook.Worksheets("SOE_2019")
Dim westCalendar As Workbook
Set westCalendar = Workbooks.Open(Filename:="Y:\Station Operations\Station Ops Shared\WEST VACATION CALENDAR 2019.xlsm")
Dim destWs As Worksheet
Set destWs = westCalendar.Worksheets("SOW_2019")
Dim lastRow As Long
lastRow = sourceWs.Range("A" & sourceWs.Rows.CountLarge).End(xlUp).Row
Dim outRow As Long
outRow = 1
Dim i As Long
For i = 2 To lastRow
If sourceWs.Cells(i, 4) = "SOW" Then
destWs.Rows(outRow).EntireRow.Value = sourceWs.Rows(i).EntireRow.Value
outRow = outRow + 1
End If
Next i
westCalendar.Close False
End Sub