i have to sort data from sheet1 to sheet2 with reference to non-empty cell in column A. and
i have written code for it as below:
Sub polo()
Dim lastrow As Long
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = Sheets("Sheet1").Cells(i - 1, 2).Value
j = j + 1
End If
Next i
End Sub
But the problem is, i am getting result as in column D of sheet2.
I want result as shown in column E.
Please help.
Try this version:
Sub polo()
Dim lastrow As Long
Dim sTemp as String
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = stemp
j = j + 1
Else
stemp = Sheets("Sheet1").Cells(i, 2).Value
End If
Next i
End Sub
Related
I have a table of headers and Row is a list of values. I'm trying to concatenate the whole table so the header is followed by the value in row A like this -
Correct
I have a loop that does this quite nicely however it has begun to take some time to work -
r = 2
c = 2
Do While Cells(1, r) <> ""
Do While Cells(c, 1) <> ""
Cells(c, r) = Cells(1, r) & Cells(c, 1)
c = c + 1
Loop
r = r + 1
c = 2
Loop
I've tried to use a formula instead -
Dim lngLastRow As Long
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2:B" & lngLastRow).Formula = "=B1 & ""_"" & A2"
But I get the following - Error
Any help would be much appreciated.
You don't need a nested loop in the code. (Unless you plan to use more columns and want to quickly expand that out without modding the code.)
Dim i As Long
Dim lr As Long
With Sheets("Sheet1")
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
.Cells(i, 2).Value = .Cells(1, 2).Value & .Cells(i, 1).Value
.Cells(i, 3).Value = .Cells(1, 3).Value & .Cells(i, 1).Value
.Cells(i, 4).Value = .Cells(1, 4).Value & .Cells(i, 1).Value
Next i
End With
With dynamic columns:
Dim i As Long
Dim j As Long
Dim lr As Long
Dim lc As Long
With Sheets("Sheet1")
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To lr
For j = 2 To lc
.Cells(i, j).Value = .Cells(1, j).Value & .Cells(i, 1).Value
Next j
Next i
End With
For your formula you need to set row for the access level and column for name to be absolute:
=CONCATENATE(B$1,$A2)
This will allow you to drag the formula around without messing up what it's grabbing
I want to combine duplicate rows with the same A and C columns values and sum their cells values for the column B (by adding the value of the textbox2 from the duplicate to the original). My problem is about the condition of the "If" in the Loop. It doesn't consider those conditions when I have duplicates and just add a new row. Is there a better way to do this?
Private Sub CommandButton1_Enter()
ActiveSheet.Name = "Sheet1"
Dim lastrow As Long
With Sheets("Sheet2")
lastrow = .Cells(Rows.Count, "H").End(xlUp).Row
For x = lastrow To 3 Step -1
For y = 3 To lastrow
If .Cells(x, 1).Value = .Cells(y, 1).Value And .Cells(x, 3).Value = .Cells(y, 3).Value And x > y Then
.Cells(y, 8).Value = .Cells(y, 8).Value + TextBox2.Text
.Cells(y, 2).Value = .Cells(y, 2).Value + TextBox2.Text
.Rows(lastrow).EntireRow.Delete
Else
.Cells(lastrow + 1, 8).Value = TextBox2.Text
.Cells(lastrow + 1, 2).Value = TextBox2.Text
.Cells(lastrow + 1, 1).Value = TextBox1.Text
.Cells(lastrow + 1, 3).Value = TextBox3.Text
Exit For
End If
Next y
Next x
End With
End Sub
Here's a picture of the data
There's no blank cell in the column H (I changed the color of the font to make it invisible).
Create a primary key by joining the 2 columns with tilde ~ and use a Dictionary Object to locate duplicates.
Option Explicit
Private Sub CommandButton1_Click()
Dim wb As Workbook, ws As Worksheet
Dim iLastRow As Long, iRow As Long, iTarget As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet2")
iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
Dim dict As Object, sKey As String
Set dict = CreateObject("Scripting.Dictionary")
' build dictionary and
' consolidate any existing duplicates, scan up
For iRow = iLastRow To 3 Step -1
' create composite primary key
sKey = LCase(ws.Cells(iRow, 1).Value) & "~" & Format(ws.Cells(iRow, 3).Value, "yyyy-mm-dd")
If dict.exists(sKey) Then
iTarget = dict(sKey)
' summate and delete
ws.Cells(iTarget, 2) = ws.Cells(iTarget, 2) + ws.Cells(iRow, 2)
ws.Cells(iTarget, 8) = ws.Cells(iTarget, 8) + ws.Cells(iRow, 8)
ws.Rows(iRow).EntireRow.Delete
Else
dict(sKey) = iRow
End If
Next
' add new record from form using dictionary to locate any existing
iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
sKey = LCase(TextBox1.Text) & "~" & Format(DateValue(TextBox3.Text), "yyyy-mm-dd")
If dict.exists(sKey) Then
iTarget = dict(sKey)
ws.Cells(iTarget, 2) = ws.Cells(iTarget, 2) + TextBox2.Text
ws.Cells(iTarget, 8) = ws.Cells(iTarget, 8) + TextBox2.Text
Else
iTarget = iLastRow + 1
ws.Cells(iTarget, 1) = TextBox1.Text
ws.Cells(iTarget, 2) = TextBox2.Text
ws.Cells(iTarget, 3) = TextBox3.Text
ws.Cells(iTarget, 8) = TextBox2.Text
End If
End Sub
i would help me about my code it compares from sheet1 two columns a,b and the duplicated transfer to sheet2 the column c
Sub COPY1()
Dim i
Dim LastRow As Long
LastRow = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Sheets("sheet1").Cells(i, "A").Value = Sheets("sheet1").Cells(i, "B").Value Then
Count = Application.WorksheetFunction.CountIf(Range("B1:B" & i), Sheets("sheet1").Cells(i, "A"))
If Count > 1 Then
Sheets("sheet1").Cells(i, "A").COPY Destination:=Sheets("sheet2").Range("B" &
Rows.Count).End(xlUp).Offset(1)
End If
End If
Next i
End Sub
Give this a try:
Sub COPY1()
Dim i As Long
Dim LastRow As Long
With Sheets("sheet1")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
v = .Cells(i, "A").Value
For j = 2 To LastRow
If v = .Cells(j, "B").Value Then
.Cells(i, "A").Copy Destination:=Sheets("sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1)
End If
Next j
Next i
End With
End Sub
Can someone help me if this is possible to do?
Logic is: If ColA = 1 and ColC >=1 then it should copy the entire row and insert new row below the last blank cell before meeting the next cell that contains then 1 will become 0.
Raw:
Final output should be:
I tried to put it as text but it doesn't seem right. the code i have for now is only this, its my first project tho. my code is still incomplete as i don't know what to do next. i tried a lot of codes but not working. here's the code:
Dim asd As Integer
Dim LastRow As Long
LastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For zxc = 2 To C
If Cells(zxc, "A").Value = 1 And Cells(zxc, "C").Value >= 1 Then
asd = asd + 1
End If
Next zxc
Dim AddCountRow As Long
AddCountRow = LastRow + asd
For i = 2 To AddCountRow
Dim A As Long
A = Worksheets("Sheet1").Cells(i, "A").Value
Dim B As Long
B = Worksheets("Sheet1"). Cells(i + 1, "D"). Value
If A >= 1 And B >= 1 Then
Cells(i + 1, "A").EntireRow.Insert
i = i + 1
End If
Next i
End Sub
Thank you so much guys!
This is a different approach. Considering maybe you have data below and
lastrow could not be reliable.
Look for the <<< Customize this >>> where I set the first cell where you have the header.
This code covers the data in the sample image:
Sub CopyInsertRows()
Dim colAValue As String
Dim colBValue As String
Dim colCValue As String
Dim colDValue As String
Dim initialCell As String
Dim rowCounter As Long
' <<< Customize this >>>
initialCell = "A4"
' Loop through all cells
For rowCounter = 2 To Rows.Count
If Range(initialCell).Cells(rowCounter, 1).Value <> vbNullString Then
colAValue = Range(initialCell).Cells(rowCounter, 1).Value
colBValue = Range(initialCell).Cells(rowCounter, 2).Value
colCValue = Range(initialCell).Cells(rowCounter, 3).Value
colDValue = Range(initialCell).Cells(rowCounter, 4).Value
ElseIf Range(initialCell).Cells(rowCounter, 1).Value = vbNullString And Range(initialCell).Cells(rowCounter + 1, 1).Value <> vbNullString Then
Range(initialCell).Cells(rowCounter + 1).EntireRow.Insert
Range(initialCell).Cells(rowCounter + 1, 1).Value = "0"
Range(initialCell).Cells(rowCounter + 1, 2).Value = colBValue
Range(initialCell).Cells(rowCounter + 1, 3).Value = colCValue
Range(initialCell).Cells(rowCounter + 1, 4).Value = colDValue
rowCounter = rowCounter + 1
End If
If Range(initialCell).Cells(rowCounter, 4).Value = vbNullString Then
Range(initialCell).Cells(rowCounter, 1).Value = "0"
Range(initialCell).Cells(rowCounter, 2).Value = colBValue
Range(initialCell).Cells(rowCounter, 3).Value = colCValue
Range(initialCell).Cells(rowCounter, 4).Value = colDValue
Exit For
End If
Next rowCounter
End Sub
This code covers the data in the sample linked file:
Sub CopyInsertRows()
Dim sourceRow As Range
Dim initialCell As String
Dim dateColumnLetter As String
Dim dateColumnNumber As Integer
Dim rowCounter As Long
' <<< Customize this >>>
initialCell = "A1" ' First cell of header row
dateColumnLetter = "AA" ' Where
' Get column number
dateColumnNumber = Range(dateColumnLetter & 1).Column
' Loop through all cells
For rowCounter = 2 To Rows.Count
If Range(initialCell).Cells(rowCounter, 1).Value <> vbNullString Then
' Store row values
Set sourceRow = Range(initialCell).Range("A" & rowCounter & ":" & dateColumnLetter & rowCounter)
ElseIf Range(initialCell).Cells(rowCounter, 1).Value = vbNullString And Range(initialCell).Cells(rowCounter + 1, 1).Value <> vbNullString Then
' Insert new row
Range(initialCell).Cells(rowCounter + 1).EntireRow.Insert
' Duplicate source row
Range(initialCell).Range("A" & rowCounter + 1 & ":" & dateColumnLetter & rowCounter + 1).Value = sourceRow.Value
' Replace first cell
Range(initialCell).Range("A" & rowCounter + 1).Value = "0"
rowCounter = rowCounter + 1
End If
If Range(initialCell).Cells(rowCounter, dateColumnNumber).Value = vbNullString Then
' Duplicate source row
Range(initialCell).Range("A" & rowCounter & ":Y" & rowCounter).Value = sourceRow.Value
' Replace first cell
Range(initialCell).Range("A" & rowCounter + 1).Value = "0"
Exit For
End If
Next rowCounter
End Sub
You will be inserting rows so work from the bottom up.
Sub addLines()
Dim i As Long, lr As Long, n As Long
With Worksheets("sheet5")
'collect last data row
lr = .Cells(.Rows.Count, "D").End(xlUp).Row + 1
'loop through the rows backwards, inserting rows and transferring values
For i = lr To 3 Step -1
If i = lr Or .Cells(i, "A") <> vbNullString Then
n = Application.Match(1E+99, .Range("A:A").Resize(i - 1, 1))
.Cells(i, "A").Resize(1, 4).Insert Shift:=xlDown
.Cells(i, "A").Resize(1, 4) = .Cells(n, "A").Resize(1, 4).Value
.Cells(i, "A") = 0
End If
Next i
End With
End Sub
I have up to 6 cells with potential data coming from 6 different places. I am trying to get only the first three cells with data transferred to another sheet WITH THE ORIGINAL FORMAT Sub Transfer_Data()
Sub Transfer_Data()
Dim i As Long, j As Long
j = 1
For i = 1 To 6
If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
Sheets("Sheet2").Cells(j, 1).Value = Sheets("Sheet1").Cells(i, 1).Value
j = j + 1
End If
If j > 3 Then Exit For
Next i
End Sub
what happens is it displays the sheet2 format and color when im trying to keep sheet1
Try it like this...
Sub Transfer_Data()
Dim i As Long, j As Long
j = 1
For i = 1 To 6
If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
Sheets("Sheet1").Cells(i, 1).Copy
Sheets("Sheet2").Cells(j, 1).PasteSpecial xlPasteFormats
Sheets("Sheet2").Cells(j, 1).PasteSpecial xlPasteValues
j = j + 1
End If
If j > 3 Then Exit For
Next i
Application.CutCopyMode = False
End Sub
Edited code as per the new requirement:
Sub Transfer_Data()
Dim i As Long, j As Long
j = 1
For i = 1 To 6
If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
Sheets("Sheet2").Cells(j, 1).Value = Sheets("Sheet1").Cells(i, 1).Value
Sheets("Sheet2").Cells(j, 1).Interior.Color = Sheets("Sheet1").Cells(i, 1).Interior.Color
j = j + 1
End If
If j > 3 Then Exit For
Next i
End Sub