Hei,
I need help with Excel. For better undrestanding, picture is attached.
Basically i need excel to go through row by row and copy all rows with set values (see picture).
Logic:
If col1 value "1" copy (always)ยด
incase col3 value "X" copy also row below (value=2)
If col3 not "X" copy and skip to next col1 = 2
If col3 not "X" copy and skip to next col1 = 1
If col1 value "1" copy (always)
incase col3 value not "X" skip to next col1=1
etc.
EDIT:ATTACHED EXCEL FILE WITH EXAMPLE OUTPUT
Excel - Picture
If Sheets(1).Cells(i, 1).Value = 1 Then
//*copy entire row and skip everything until Sheets(1).Cells(i, 1).Value = 1*//
else if Sheets(1).Cells(i, 1).Value = 1 And Sheets(1).Cells(i, 3).Value = "x" Then
*copy entire row and continue loop*
If Sheets(1).Cells(i, 1).Value = 2 Then
//*copy entire row and skip everything until Sheets(1).Cells(i, 1).Value = 2 or higer*//
else if Sheets(1).Cells(i, 1).Value = 2 And Sheets(1).Cells(i, 3).Value = "x" Then
*copy entire row and continue loop*
If Sheets(1).Cells(i, 1).Value = 3 Then
//*copy entire row and skip everything until Sheets(1).Cells(i, 1).Value = 3 or higher*//
else if Sheets(1).Cells(i, 1).Value = 3 And Sheets(1).Cells(i, 3).Value = "x" Then
*copy entire row and continue loop*
If Sheets(1).Cells(i, 1).Value = 4 Then
//*copy entire row and skip everything until Sheets(1).Cells(i, 1).Value = 4 or higher*//
else if Sheets(1).Cells(i, 1).Value = 4 And Sheets(1).Cells(i, 3).Value = "x" Then
*copy entire row and continue loop*
I have made changes to the code, now it copies data from columns A:E, to add more columns change where it says "5" in Cells(i + 1, 5) or Cells(counter_rows, 5) and add a different column number.
The rows with data are stored in an array to speed up the code and make it more compact.
Also you should put this subroutine in a MODULE in VBA. Don't add code to Sheets.
Sub copy_rows_to_sheet2()
Dim nb_rows As Integer
Dim counter_rows As Integer
Application.ScreenUpdating = False 'speed up code
nb_rows = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row 'count the number of rows with data on sheet(1)
counter_rows = 2 'the first row on sheet(2) where we start copying data from
Dim Arr() As Variant ' declare an unallocated array, stores data from range on the sheets (any number of rows and columns)
For i = 2 To nb_rows
Sheets(1).Select 'to add data to array, first select the sheet1
If Sheets(1).Cells(i, 1).Value = 1 Or Sheets(1).Cells(i, 1).Value = 2 Then
If Sheets(1).Cells(i, 3).Value = "x" Then 'we copy 2 rows when we have x in col 3
Arr = Range(Cells(i, 1), Cells(i + 1, 5)).Value 'copy all values from row i and next row counter_rows and columns (A to E=5)
Sheets(2).Select 'before the array is pasted to sheet2 first it needs to be selected
Range(Cells(counter_rows, 1), Cells(counter_rows + 1, 5)).Value = Arr
counter_rows = counter_rows + 2 'counter increments by 2 rows
Else
Arr = Range(Cells(i, 1), Cells(i, 5)).Value 'copy row i and 5 columns
Sheets(2).Select
Range(Cells(counter_rows, 1), Cells(counter_rows, 5)).Value = Arr
counter_rows = counter_rows + 1 'counter increments by 1 row
End If
End If
Next i
Application.ScreenUpdating = False 'turn back
End Sub
Related
I have some data like below :
A
1
2
B
1
2
3
C
1
2
3
Every group separated by space and title is appeared in first line of group
I need to add title to first every below rows like this :
A1
A2
B1
B2
B3
C1
C2
C3
I find this code but not working properly :
Sub InsertRowBelowHeader()
Rows(ActiveWindow.SplitRow + 1).Insert
End Sub
Maybe something like this:
Code:
Option Explicit
Sub GroupName()
Dim lRow As Long
Dim i As Long
Dim GroupName As String
lRow = Cells(Rows.Count, "A").End(xlUp).Row 'Go to last row
For i = 1 To lRow 'Loo from 1st row to last row
If i = 1 Then 'If loop is first row
GroupName = Cells(1, "A").Value 'Then take the value for group name
Else
If Cells(i, "A").Value = "" Then 'Check if cell is empty
'If empty do nothing
Else
If Not IsNull(Cells(i, "A").Value) And Cells(i - 1, "A").Value = "" Then 'If current cell is not null and previous cell is not blank then
GroupName = Cells(i, "A").Value 'take the group name
Else
Cells(i, 2).Value = GroupName & Cells(i, "A").Value 'Else print the combination of group name + cell value
End If
End If
End If
Next i
Dim j As long
For j = lRow To 2 Step -1 'To delete empty spaces (row 5, row 10 in example)
If Cells(j, "B").Value = "" And Cells(j - 1, "B").Value = "" Then
Range(Cells(j, "A"), Cells(j, "A")).EntireRow.Delete
End If
Next j
End Sub
I want sheets "Status" and "Ref" compared. If the values match in both columns Status!F and Ref!B AND Status!Q and Ref!C for a particular individual's data in a row, then copy the value from Ref!F to Status!H
This is my first ever attempt at writing code so it's probably full of errors, but the debugger points out the first If statement in particular. I've tried it with and without parentheses.
Sub help()
Dim i As Long
Dim j As Long
Dim index As Integer
Sheet1LastRow = Worksheets("Status").Range("F" & Rows.Count).End(xlUp).Row
Sheet2LastRow = Worksheets("Ref").Range("B" & Rows.Count).End(xlUp).Row
For index = 1 To Sheet1LastRow
If ((Worksheets("Status").Cells(i, 6).Value = Worksheets("Ref").Cells(j, 2).Value) And (Worksheets("Status").Cells(i, 17).Value = Worksheets("Ref").Cells(j, 3).Value)) Then Worksheets("Status").Cells(i, 8).Value = Worksheets("Ref").Cells(j, 6)
Next
index = index + 1
j = j + 1
i = i + 1
Do Until index = Sheet1LastRow
Loop
End Sub
edit - a note--these sheets are not in the same order. so row 1500 in Status could match something on row 3 on ref, for example
Try this
For i = 1 To Sheet1LastRow
For j = 1 To Sheet2LastRow
If ((Worksheets("Status").Cells(i, 6).Value = Worksheets("Ref").Cells(j, 2).Value) and (Worksheets("Status").Cells(i, 17).Value = Worksheets("Ref").Cells(j, 3).Value)) Then
Worksheets("Status").Cells(i, 8).Value = Worksheets("Ref").Cells(j, 6).Value
Exit for
End if
Next j
Next i
I have an Excel Table, with some columns. But at the moment a have a problem with column Duration.
When I scrolled down the table, i have unexpectedly noticed, that many IDs have empty lines, and only one line of this ID has an actual value.
Is it possible to fill up other empthy lines with this only one existing value using VBA? That means, that all empty values for ID6979960 should be filled up with a value 42:15:56, and so on.
Without that, my other calculations in my table, don't work properly.
I don't know exactly how copying of values works in VBA.
Public Sub FillEmpty()
Dim finded As Range
Dim Sheet As Worksheet
Set Sheet = ActiveSheet 'or any other sheet -> .Sheets("")
With Sheet
lastrow = .Cells(1, 1).End(xlDown).Row
For i = 1 To lastrow
If StrComp(.Cells(i, 2).Value, "") = 0 Then
Set finded = .Columns(2).Find("*", after:=.Cells(i, 2), LookIn:=xlValues)
ID = .Cells(finded.Row, 1).Value
Filler = .Cells(finded.Row, 2).Text
Else
ID = .Cells(i, 1).Value
Filler = .Cells(i, 2).Text
End If
Index = i
While ID = .Cells(Index, 1).Value
.Cells(Index, 2).Value = Filler
Index = Index + 1
Wend
Next i
End With
End Sub
Made it real quick so not the most optimal solution. I tested it with your example and it works. Not sure with many more rows. Check it and let me know if it works for you.
Sub fillerv2()
rowscnt = 1000
tmi = 1
tm = ""
For i = 1 To rowscnt
If tm <> Cells(i, 1).Value Then
For o = tmi To i - 1
If IsEmpty(Cells(o, 2).Value) = False Then
Pattern = Cells(o, 2).Value
Exit For
End If
Next o
For o = tmi To i - 1
Cells(o, 2).Value = Pattern
Next o
tm = Cells(i, 1).Value
tmi = i
End If
Next i
I am copying data from one sheet to another, from source range(Q5:AIxxx) to destination range(C6:Uxxx)
My VBA code starts with a cell and loops to the end of the column to finish copying that column's data:
Set s = Worksheets("Source")
Set d = Worksheets("Destination")
Dim i As Integer, j As Integer
j = 6
For i = 5 To 1500
If s.Cells(i, 1).Value = "a" Or s.Cells(i, 1).Value = "b" Then
d.Cells(j, 3).Value = s.Cells(i, 17).Value
j = j + 1
End If
Next i
I have > 20 columns to move, is there a way I can copy the row at once? something like this:
d.Cells(j, 3:21).Value = s.Cells(i, 17:35).Value
At the moment, I'm having to specify each column:
d.Cells(j, 3).Value = s.Cells(i, 17).Value 'column 1
d.Cells(j, 4).Value = s.Cells(i, 18).Value 'column 2
d.Cells(j, 5).Value = s.Cells(i, 19).Value 'column 3
etc
You can do it by
d.range(d.cells(j,3), d.cells(j,21)).copy
s.range(s.cells(i,17), s.cells(i,35)).pastespecial xlvalues
You can use:
.Range(<your_range>).copy
For example do:
Activesheet.Range("A1:B10").Copy
and thenjust paste anywhere you want with .Paste
ActiveSheet.Paste Destination:=Worksheets(2).Range("D1:D5")
It's a build in function in vba.
See here also for copying Range:
https://msdn.microsoft.com/en-us/library/office/ff837760.aspx
And for Paste:
https://msdn.microsoft.com/en-us/library/office/ff821951.aspx
Using ranges instead can make it a bit easier:
Dim s As Range, d As Range
Set d = Worksheets("Destination").Cells(6, 15) ' notice the column 15
For Each s in Worksheets("Source").Range("A5:A1500")
If s = "a" Or s = "b" Then
d(,3) = s(,3)
d(,4) = s(,4)
' or d(,3).Resize(,19) = s(,3).Resize(,19) ' .Value optional
Set d = d.Offset(1) ' move to next row
End If
Next
There are easier ways to do that without VBA. For example Power Query, PivotTable, Copy Link and Table Filter, Data tab > From Access, etc.
I have a spreadsheet where column A information starts on row 6 and I have the unique values from this list as headers across the top in Row 1 starting at column D. What I want to do is if a cell in column A matches a header row, copy the information in the cell in column C to the corresponding Header.
ORIGINAL FORMAT
DESIRED FORMAT
Here is the code that I have tried but it is not giving me the desired results:
For i = 6 To lastRow
For j = 4 To lastColumn
If Cells(i, 1) = Cells(1, j) Then
wksActRawData.Cells(i, 3).Value = wksActRawData.Cells(i, j).Value
End If
Next j
Next i
Assuming you did write lastRow and lastColumn functions, the only error in your code is the data which gets the cell values
If Cells(i, 1) = Cells(1, j) Then
wksActRawData.Cells(i, 3).Value = wksActRawData.Cells(i, j).Value
End If
Which should really be the other way around, plus I'd add a line to clear the old prices, as follows
If Cells(i, 1) = Cells(1, j) Then
Cells(i, j).Value = Cells(i, 3).Value
Cells(i, 3).ClearContents
End If
It did work for me this way