I want to copy cell data from "Sheet2" to "Sheet1" if the value in column "H" on "Sheet2" is not equal to "0" (zero).
If the statement is true, I want to copy
"Sheet2:A2" to "Sheet1:A7",
"Sheet2:F2" to "Sheet1:C7",
"Sheet2:G2" to "Sheet1:E7", and
"Sheet2:H2" to "Sheet1:G7".
I then want to loop through the remaining rows on "Sheet2" and continue copying until the worksheet runs out of data.
Use the following code
Sub filldata()
LastRow = Sheet2.Range("H1048576").End(xlUp).Row
i = 2
j = 7
For i = 2 To LastRow
If Sheet2.Range("H" & i).Value <> 0 Then 'the condition to check
Sheet1.Range("A" & j).Value = Sheet2.Range("A" & i).Value
Sheet1.Range("C" & j).Value = Sheet2.Range("F" & i).Value
Sheet1.Range("E" & j).Value = Sheet2.Range("G" & i).Value
Sheet1.Range("G" & j).Value = Sheet2.Range("H" & i).Value
j = j + 1
End If
Next
End Sub
Related
I am trying to copy from Raw Data to Consolidated Data.
If a row in the Raw Data already exists (by checking both the Full Name and the Identity Number together with the AND Condition as the composite key of using both values is unique) in the Consolidated Data it will check through the columns and update it if there are any changes.
For example Ben with the Identity Number of 3333 changed his Contact and Email. So after updating it will have the updated Contact and Email.
Secondly, if the row in the Raw Data doesn't exist it will add to the bottom of the Consolidated Data.
I tried a nested loop for this. I am facing the problem of duplicate entries as my code is checking the row in the Raw Data with every row in the Consolidated Data.
For example in the Raw Data I have Alan (1111), Ben (2222), Ben (3333), Calvin (4444). In the New Consolidated Data I will turn out to have more than four rows after updating.
This is the raw data
This is the old consolidated data
This is the final consolidated data
Dim i As Long, lastRow As Long
Set rawData = sheet1
Set finalData = sheet2
lastRow = sheet1.Cells(rows.Count, "A").End(xlUp).Row
finalLastRow = sheet2.Cells(rows.Count, "A").End(xlUp).Row
MsgBox lastRow
MsgBox finalLastRow
' If the sheet is empty
If (finalLastRow = 2) Then
For i = 3 To lastRow
' Test if cell if empty
If (rawData.range("A" & i).Value <> "") Then
finalData.range("A" & i).Value = rawData.range("A" & i).Value
finalData.rNeange("B" & i).Value = rawData.range("B" & i).Value
finalData.range("C" & i).Value = rawData.range("C" & i).Value
finalData.range("D" & i).Value = rawData.range("D" & i).Value
finalData.range("E" & i).Value = rawData.range("E" & i).Value
End If
Next i
' If the sheet is not empty
ElseIf (finalLastRow <> 2) Then
Dim newLastRow As Long
newLastRow = 4
For i = 3 To lastRow
For j = 3 To finalLastRow
' Test if cell is the same
'Dim matchScore As Long
' Full Name and Identity Number remain same
If (rawData.range("A" & i).Value) = (finalData.range("A" & j).Value) And (rawData.range("B" & i).Value) = (finalData.range("B" & j).Value) Then
finalData.range("C" & j).Value = rawData.range("C" & i).Value
finalData.range("D" & j).Value = rawData.range("D" & i).Value
finalData.range("E" & j).Value = rawData.range("E" & i).Value
MsgBox "SAME"
' New Record
Else
' Check through the sheet2 to see if the row have been added to it
newLastRow = newLastRow + 1
finalData.range("B" & newLastRow).Value = rawData.range("B" & i).Value
End If
finalLastRow = sheet2.Cells(rows.Count, "A").End(xlUp).Row
Next j
Next i
End If
I have added another For loop in the Else statement to check through the columns to see if it exists.
' New Record
Else
Dim isDataInCurrentRows As Boolean
isDataInCurrentRows = False
For checkRow = 3 To finalLastRow
If (rawData.range("B" & i).Value) = (finalData.range("B" & checkRow).Value) And (rawData.range("D" & i).Value) = (finalData.range("D" & checkRow).Value) Then
isDataInCurrentRows = True
Exit For
End If
Next checkRow
If isDataInCurrentRows = False Then
finalData.range("A" & finalLastRow + 1).Value = rawData.range("A" & i).Value
finalData.range("B" & finalLastRow + 1).Value = rawData.range("B" & i).Value
finalData.range("C" & finalLastRow + 1).Value = rawData.range("C" & i).Value
finalData.range("D" & finalLastRow + 1).Value = rawData.range("D" & i).Value
finalData.range("E" & finalLastRow + 1).Value = rawData.range("E" & i).Value
finalData.range("F" & finalLastRow + 1).Value = rawData.range("F" & i).Value
finalData.range("G" & finalLastRow + 1).Value = rawData.range("G" & i).Value
finalData.range("H" & finalLastRow + 1).Value = rawData.range("H" & i).Value
finalData.range("I" & finalLastRow + 1).Value = Date
End If
End If
I have excel sheet with around 40k records and 5 columns. I want to search duplicates in column 3, 4, 5 and copy whole row in new sheet.
#Emm Jay could you please be more specific? I m not sure what are you asking for, but the below code may help you to get an overall idea.
Let's say that Sheet 1 contains our data & duplicate rows will copy on Sheet 2.
Sheet 1:
Sheet 2 - Output:
Code:
Option Explicit
Sub Duplicates()
Dim LastrowS1 As Long, LastrowS2 As Long, i As Long, j As Long
Dim CombineStrI As String, CombineStrJ As String
LastrowS1 = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastrowS1
CombineStrI = Sheet1.Range("C" & i).Value & "_" & Sheet1.Range("D" & i).Value & "_" & Sheet1.Range("E" & i).Value
For j = 2 To LastrowS1
CombineStrJ = Sheet1.Range("C" & j).Value & "_" & Sheet1.Range("D" & j).Value & "_" & Sheet1.Range("E" & j).Value
If j <> i Then
If CombineStrI = CombineStrJ Then
Sheet1.Rows(i).Copy
LastrowS2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
Sheet2.Range("A" & LastrowS2 + 1).PasteSpecial
End If
End If
Next j
Next i
End Sub
Final One:enter image description hereI want to insert blank row with a specific column range above a particular row.
For example:
There were 2 sets of data in a single sheet ,ie, 1st set col A to Col E and 2nd set Col F to Col J. I need to compare Column Ai with Column Fi (where i indicates the position of row) and if both values are same then the comparison can be proceeded like Bi with Gi, Ci with Hi and so and so and if not, I need to shift that set of 2nd data Fi to Ji to next row..ie. if the whole set is in 6th position I need to shift them down to 7th position and make the 6th position of Fi to Ji blank....
Sub Dcompare()
Dim endRow As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
endRow = Sheet1.Range("A999999").End(xlUp).Row
For i = 2 To endRow
If Sheet1.Range("A" & i).Value = Sheet1.Range("F" & i).Value Then
Sheet1.Range("K" & i).Value = "Yes"
Else
ws.Range("F" & i & ":J" & i).Offset(1, 0).Value = ws.Range("F" & i & ":J" & i).Value
ws.Range("F" & i & ":J" & i).Value = ""
End If
Next i
For j = 2 To endRow
If Sheet1.Range("K" & j).Value = "Yes" Then
If Sheet1.Range("B" & j).Value = Sheet1.Range("G" & j).Value Then
Sheet1.Range("L" & j).Value = "Yes"
Else
Sheet1.Range("L" & j).Value = "No"
End If
If Sheet1.Range("C" & j).Value = Sheet1.Range("H" & j).Value Then
Sheet1.Range("M" & j).Value = "Yes"
Else
Sheet1.Range("M" & j).Value = "No"
End If
If Sheet1.Range("D" & j).Value = Sheet1.Range("I" & j).Value Then
Sheet1.Range("N" & j).Value = "Yes"
Else
Sheet1.Range("N" & j).Value = "No"
End If
If Sheet1.Range("E" & j).Value = Sheet1.Range("J" & j).Value Then
Sheet1.Range("O" & j).Value = "Yes"
Else
Sheet1.Range("O" & j).Value = "No"
End If
End If
Next j
End Sub
------>Final Code Inserted---------
Sub Dcompare()
Dim endRow As Long
Dim ws As Worksheet
Dim dShift As Boolean
Set ws = ThisWorkbook.Worksheets(1)
endRow = ws.Range("A999999").End(xlUp).Row
For i = 2 To endRow + 1
If ws.Range("A" & i).Value = ws.Range("F" & i).Value Then
dShift = False
ws.Range("K" & i).Value = "Yes"
Else
If Not dShift Then
ws.Range("F" & i & ":J" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ws.Range("A" & i + 1 & ":E" & i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
endRow = endRow + 1
dShift = True
Else
dShift = False
End If
End If
j = i
If ws.Range("K" & j).Value = "Yes" Then
If ws.Range("B" & j).Value = ws.Range("G" & j).Value Then
ws.Range("L" & j).Value = "Yes"
Else
ws.Range("L" & j).Value = "No"
End If
If ws.Range("C" & j).Value = ws.Range("H" & j).Value Then
ws.Range("M" & j).Value = "Yes"
Else
ws.Range("M" & j).Value = "No"
End If
If ws.Range("D" & j).Value = ws.Range("I" & j).Value Then
ws.Range("N" & j).Value = "Yes"
Else
ws.Range("N" & j).Value = "No"
End If
If ws.Range("E" & j).Value = ws.Range("J" & j).Value Then
ws.Range("O" & j).Value = "Yes"
Else
ws.Range("O" & j).Value = "No"
End If
Else
End If
Next i
MsgBox "The value of endRow is : " & endRow, vbInformation
End Sub
Based on your explanations, this is what I interpret your challenge as:
Evaluate Ai with Fi --> Ei with Ji from left to right, and indicate in helper-columns whether the evaluation succeeded or not
If the first evaluation is Not Equal, offset the range Fi:Ji downwards exactly one row
If a range has been shifted down, the loop should evaluate this line but never shift it again regardless of outcome of the evaluation
This code satisfies those conditions (change i and other row variables to your needs):
Sub Dcompare()
Dim endRow As Long
Dim ws As Worksheet
Dim dShift As Boolean
Set ws = ThisWorkbook.Worksheets(1)
endRow = ws.Range("A999999").End(xlUp).Row
' Set initial value of helper columns to no - saves miniscule time and complexity in the loop
ws.Range("L" & 1 & ":O" & endRow).Value = "No"
For i = 1 To endRow
If ws.Range("A" & i).Value = ws.Range("F" & i).Value Then
dShift = False
ws.Range("L" & i).Value = "Yes"
Else
If Not dShift Then
ws.Range("F" & i & ":J" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
' Remember that we just shifted a row
dShift = True
Else
' Reset shift counter
dShift = False
End If
End If
For j = 2 To 4
If dShift Then Exit For
If ws.Cells(i, j).Value = ws.Cells(i, j + 5).Value Then ws.Cells(i, j + 11).Value = "Yes"
Next j
Next i
End Sub
However, it seems strange to me that you would want this functionality? Please confirm that it is correct. The behavior it yields in the worksheet is very strange.
Let me show with images. Orange background means the code will show the cell as a match. Green background means the code will show that the cell doesn't match.
Before the code it looks like this:
After the code it looks like this:
I have about 70,000 rows of data and two columns (Field,Data) which repeats every 50-100 rows (Record). I would like to write something that searches for the values based on "Field Text" (I'm only interested in about 5 fields) and paste the value into a new worksheet with rows as records and columns as fields. The first field I'm searching for will need to indicate new row/record.
My first attempt at this failed, and I've found little help on the forums. Although it looks like maybe a pivot table could do this?
Visual of what I'd like to do:
Example
EDIT:
I got the result I wanted but my do until "END" isnt catching. I do have "END" in the last cell of the data. Also, I'm sure there is a more efficient way to do this, any advice? Thanks!
Sub TracePull()
Dim i As Long
Dim j As Long
i = 1
j = 1
ActiveWorkbook.Sheets("Trace").Range("A1").Select
Do Until Range("A" & i) = "END"
Do Until ActiveCell = "OTDRFilename"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRFilename" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("A" & j + 1).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
j = j + 1
'Else
' i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRSpan length"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRSpan length" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("B" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRSpan loss"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRSpan loss" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("C" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRAverage loss"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRAverage loss" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("D" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRSpan ORL"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRSpan ORL" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("E" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRWavelength"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRWavelength" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("F" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
Range("A" & i).Select
Loop
End Sub
I think your main problem is incrementing i twice (which passes 'END' cell) at the bottom of your code.
One way to make it more readable is by using select case. Also, you can speed up the code by assigning the value directly (without copy paste) and by turning off screen updating since you have 70,000 rows. Those things will improve performance considerably.
Sub TracePull()
ScreenUpdating = False
Dim i As Long
Dim j As Long
i = 1
j = 1
ActiveWorkbook.Sheets("Trace").Range("A1").Select
Do Until Range("A" & i) = "END"
Select Case ActiveCell.Text
Case "OTDRFilename"
ActiveWorkbook.Sheets("Sheet1").Range("A" & j + 1).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRSpan length"
ActiveWorkbook.Sheets("Sheet1").Range("B" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRSpan loss"
ActiveWorkbook.Sheets("Sheet1").Range("C" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRAverage loss"
ActiveWorkbook.Sheets("Sheet1").Range("D" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRSpan ORL"
ActiveWorkbook.Sheets("Sheet1").Range("E" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRWavelength"
ActiveWorkbook.Sheets("Sheet1").Range("F" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
End Select
i = i + 1
j = j + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
Loop
ScreenUpdating = True
End Sub
You might also want to consider defining the workbook and worksheet rather than relying upon activesheet. In addition, the code with break if someone forget to have 'END' entered in the last cell, so maybe just get last cell used instead of looking for 'END'
Dim wb As Workbook
Dim wskA As Worksheet
Dim wskB As Worksheet
wb = ActiveWorkbook
wskA = wb.Sheets("Trace")
wskB = wb.Sheets("Sheet1")
numofrows = wskA.Offset(wskA.Rows.Count - 1, 0).End(xlUp).Row
wskA.Range("A1").Select
Do Until i > numofrows
Select Case ActiveCell.Text
Case "OTDRFilename"
wskB.Range("A" & j + 1).Value = wskA.Range("B" & i).Value
I have been trying to run the same Do While loop function across multiple worksheets in a workbook and compile the data in another worksheet. The code works for the one worksheet that is specified but how do I get it to work across the others that are in the workbook at the same time?
Also worth mentioning that I only want it to run on some of the worksheets not all that are in the workbook (sheets are named as years - 2014, 2015 etc).
This is the code
Sub Total_Button1_Click()
Dim i As Integer
Dim strSheetFrom As String
Dim j As Integer
Dim strSheetTo As String
i = 3
j = 2
strSheetFrom = "2014"
strSheetTo = "Total"
Do While Trim(Sheets(strSheetTo).Range("B" & CStr(j)).Text) <> ""
j = j + 2
Loop
Do While Trim(Sheets(strSheetFrom).Range("B" & CStr(i)).Text) <> ""
If UCase(Trim(Sheets(strSheetFrom).Range("A" & CStr(i)).Text)) = "Y" Then
Sheets(strSheetTo).Range("B" & j & ":G" & j).Value = Sheets(strSheetFrom).Range("B" & i & ":G" & i).Value
Sheets(strSheetTo).Range("H" & j & ":I" & j).Value = Sheets(strSheetFrom).Range("I" & i & ":J" & i).Value
Sheets(strSheetTo).Range("J" & j & ":J" & j).Value = Sheets(strSheetFrom).Range("L" & i & ":L" & i).Value
Sheets(strSheetTo).Range("K" & j & ":K" & j).Value = Sheets(strSheetFrom).Range("Q" & i & ":Q" & i).Value
Sheets(strSheetTo).Range("L" & j & ":AH" & j).Value = Sheets(strSheetFrom).Range("s" & i & ":AO" & i).Value
j = j + 1
End If
i = i + 1
Loop
MsgBox "Total book created"
End Sub
Try making your strSheetFrom variable an array something like this:
strSheetFrom = new strSheetFrom[3]
strSheetFrom[2] = "2012"
strSheetFrom[1] = "2013"
strSheetFrom[0] = "2014"
Then put your code into another loop like so:
dim w as integer
for w = 0 To 3
Do While Trim(Sheets(strSheetTo).Range("B" & CStr(j)).Text) <> ""
j = j + 2
Loop
Do While Trim(Sheets(strSheetFrom[w]).Range("B" & CStr(i)).Text) <> ""
If UCase(Trim(Sheets(strSheetFrom[w]).Range("A" & CStr(i)).Text)) = "Y" Then
Sheets(strSheetTo).Range("B" & j & ":G" & j).Value = Sheets(strSheetFrom[w]).Range("B" & i & ":G" & i).Value
Sheets(strSheetTo).Range("H" & j & ":I" & j).Value = Sheets(strSheetFrom[w]).Range("I" & i & ":J" & i).Value
Sheets(strSheetTo).Range("J" & j & ":J" & j).Value = Sheets(strSheetFrom[w]).Range("L" & i & ":L" & i).Value
Sheets(strSheetTo).Range("K" & j & ":K" & j).Value = Sheets(strSheetFrom[w]).Range("Q" & i & ":Q" & i).Value
Sheets(strSheetTo).Range("L" & j & ":AH" & j).Value = Sheets(strSheetFrom[w]).Range("s" & i & ":AO" & i).Value
j = j + 1
End If
i = i + 1
Loop
w -= 1
next
I haven't tested it, but something like that. You get the idea.
Use a For Each and iterate over the Worksheet collections like this
'Variables
Dim useWorkSheet As Worksheet
Dim totalWorkSheet As Worksheet
Dim yearAsNumeric As Integer
Dim startingYear As Integer
'Settings
startingYear = 2014
'To reference the total worksheet so we can work with it
Set totalWorkSheet = ActiveWorkbook.Worksheets("Total")
'Iterate over each item in the collection
For Each useWorkSheet In ActiveWorkbook.Worksheets
'Force the name into a numeric value. If it starts with anything non numeric (A-Z|a-z|$,#,etc) then it will return 0
yearAsNumeric = Val(useWorkSheet.Name)
'Greater than or equal to the year we want to start with?
If yearAsNumeric >= startingYear Then
'Yes. Do your stuff here
useWorkSheet.Name
End If
Next