I have an excel sheet which need do format the data
I need to format this data like this in different sheet
Note - This a small sample I created for your understanding
my test macro is below. If you want to use it, you just need to rename your sheets - "DataSheet" for the one with the data and "ResultSheet" where the result will be stored.
Sub Reformat()
Dim letter As String
Dim iRow As Integer
Dim rng As Excel.Range
Sheets("ResultSheet").Range("A1:A" & Range("A1").End(xlDown).Row).Value = Range("A1:A" & Range("A1").End(xlDown).Row).Value
Sheets("ResultSheet").Select
Range("A1:A" & Range("A1").End(xlDown).Row).RemoveDuplicates Columns:=1, Header:=xlNo
Set rng = Range("A1:A" & Range("A1").End(xlDown).Row)
For i = 1 To Sheets("DataSheet").Range("A1").End(xlDown).Row
letter = Sheets("DataSheet").Range("A" & i).Value
iRow = WorksheetFunction.Match(letter, rng)
If Range("B" & iRow).Value = "" Then
Range("B" & iRow).Value = Sheets("DataSheet").Range("B" & i).Value
Else
Range("A" & iRow).End(xlToRight).Offset(0, 1).Value = Sheets("DataSheet").Range("B" & i).Value
End If
Next i
End Sub
Related
I am fairly new to scripting and I find myself stuck on what I feel like is an easy solution. In summary, in excel, I have all my data on Sheet1(import) and I want to pull data from that list into my Sheet2(export) using Column A (on my Sheet2) as my list of data to pull.
I have managed to get the data to pull however, I am not able to get it to pull multiples. Example, I have ABC in my Column A (Sheet2), I click my button to pull data, it pulls the first ABC on Sheet1 that it finds then stops. I need it to pull all the ABC's off sheet1 before moving onto the next cell to search.
This is my first post so I apologize if this is a rough read or I should have added more content.
---------------Code----------------
Private Sub DataImport_Click()
Dim I, Total, fRow As Integer
Dim Found As Range
'Listed Data to locate
Total = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
'Where to locate data to export
For I = 2 To Total
answer1 = Worksheets(2).Range("A" & I).Value
Set Found = Sheets(1).Columns("F").Find(What:=answer1, LookAt:=xlWhole, SearchDirection:=x1Next)
'To Do when there is no data
If Found Is Nothing Then
'Leave the cell blank
'To Do when there is data & where/what data to pull
Else
fRow = Sheets(1).Columns("F").Find(What:=answer1, LookAt:=xlWhole, SearchDirection:=x1Next).Row
Worksheets(2).Range("C" & I).Value = Worksheets(1).Range("F" & fRow).Value
Worksheets(2).Range("D" & I).Value = Worksheets(1).Range("G" & fRow).Value
Worksheets(2).Range("E" & I).Value = Worksheets(1).Range("H" & fRow).Value
Worksheets(2).Range("F" & I).Value = Worksheets(1).Range("C" & fRow).Value
Worksheets(2).Range("G" & I).Value = Worksheets(1).Range("E" & fRow).Value
End If
Next I
End Sub
You are only processing the first found item. You can use a Do loop to process all of them as below.
Set Found = Sheets(1).Columns("F").Find(What:=answer1, LookAt:=xlWhole, SearchDirection:=x1Next)
If Not Found Is Nothing Then
Do Until Found Is Nothing
'your logic for each found item
Set Found = Sheets(1).Columns("F").FindNext(Found)
Loop
End If
I appreciate the help and after getting many possible solutions to the issue we ended up using this code found below. Thank you again to all the help!
Private Sub ExtractData_Click()
Dim i As Integer
Dim j As Integer
Dim intSourceRowCt As Integer
Dim intSearchRowCt As Integer
Dim intCopyToRow As Integer
'Set row to Start Copying to
intCopyToRow = 2
'Listed Data to locate
intSourceRowCt = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
intSearchRowCt = Sheets(1).Range("F" & Rows.Count).End(xlUp).Row
'Loop through Source
For i = 2 To intSourceRowCt
'Loop through Search
For j = 2 To intSearchRowCt
'Copy Row if Matches
If (Worksheets(1).Range("F" & j).Value = Worksheets(2).Range("A" & i).Value) Then
Worksheets(2).Range("C" & intCopyToRow).Value = Worksheets(1).Range("F" & j).Value
Worksheets(2).Range("D" & intCopyToRow).Value = Worksheets(1).Range("G" & j).Value
Worksheets(2).Range("E" & intCopyToRow).Value = Worksheets(1).Range("H" & j).Value
Worksheets(2).Range("F" & intCopyToRow).Value = Worksheets(1).Range("C" & j).Value
Worksheets(2).Range("G" & intCopyToRow).Value = Worksheets(1).Range("E" & j).Value
'Increment Insert Row
intCopyToRow = intCopyToRow + 1
End If
Next j
Next i
End Sub
I want to select whole rows of a range (C14:M34) if value = 1 in a column(F14:F34). Otherwise I want to select the same rows except a specific column(G).
I can do this if I have only a single row but how can I apply this for a range (multiple rows)?
Hereby my code (which is not working):
ActiveSheet.Range("$C$13:$M$34").AutoFilter Field:=6, Criteria1:="<>"
Dim d As Range
For Each d In Range("F14:F34")
If d.Value = 1 Then
ActiveSheet.Range("C14:M34").Select
Else
Application.Union(Range("C14:F34"), Range("H14:M34")).Select
End If
Selection.Copy
Next d
Try this code, please:
Sub testSelecting()
Dim sh As Worksheet, rngSel As Range, i As Long
Set sh = ActiveSheet
For i = 14 To 34
If sh.Range("F" & i).Value = 1 Then
If rngSel Is Nothing Then
Set rngSel = sh.Range("C" & i & ":M" & i)
Else
Set rngSel = Union(rngSel, sh.Range("C" & i & ":M" & i))
End If
Else
If rngSel Is Nothing Then
Set rngSel = Union(sh.Range("C" & i & ":F" & i), sh.Range("H" & i & ":M" & i))
Else
Set rngSel = Union(rngSel, sh.Range("C" & i & ":F" & i), sh.Range("H" & i & ":M" & i))
End If
End If
Next i
If rngSel.Cells.count > 1 Then rngSel.Select: Stop
rngSel.Copy
End Sub
The code is not tested, because I do not have your file to do that. It is based only on logic. It stops after selection, in order to let you appreciate that the selected range is the one you need.
Please confirm that it works as you need, or what problem does it create, if any...
I need to create a macro that can take data in columns F through I and autofill it down to the last cell in column E that has data in it. The code below almost does what I need it to do. However, I want to be able to use this macro with different data further down in columns F:I
Dim lastrow As Long
lastrow = Range("e" & Rows.Count).End(xlUp).Row
Dim x(1 To 4) As Variant
With ThisWorkbook.Sheets("sheet1")
x(1) = Range("f2")
x(2) = Range("g2")
x(3) = Range("H2")
x(4) = Range("I2")
.Range("F3:i3").Formula = x
.Range("f3:i" & lastrow).FillDown
End With
Like this:
With ThisWorkbook.Sheets("sheet1")
lastrow = Range("E" & Rows.Count).End(xlUp).Row
For i = 3 To lastrow
.Range("F" & i).Formula = .Range("F2").Formula
.Range("G" & i).Formula = .Range("G2").Formula
.Range("H" & i).Formula = .Range("H2").Formula
.Range("I" & i).Formula = .Range("I2").Formula
Next i
End With
I know very little about VBA code, but I can follow along the lines of logic in a given example. So I googled and found a code I edited to highlight duplicates in a worksheet. However, I have a workbook with three sheets. I would like to adapt this to compare sheet 1 and sheet 3, then highlight the duplicates in sheet 1.
Sub Highlight_Dups()
Dim startRow As Integer
startRow = 2
Dim row As Integer
row = startRow
Do While (Range("A" & row).Value <> "")
Dim innerRow As Integer
innerRow = row + 1
Dim StudentID As String
Dim DT As String
Dim Description As String
StudentID = Range("A" & row).Value
DT = Range("H" & row).Value
Description = Range("J" & row).Value
Do While (Range("A" & innerRow).Value <> "")
If (Range("A" & innerRow).Value = StudentID And Range("H" & innerRow).Value = DT And Range("J" & innerRow).Value = Description) Then
Range("X" & row).Value = Range("X" & row).Value & innerRow & ", "
Range("X" & innerRow).Value = Range("X" & innerRow).Value & row & ", "
Rows(row).Interior.ColorIndex = 6
Rows(innerRow).Interior.ColorIndex = 6
End If
innerRow = innerRow + 1
Loop
row = row + 1
Loop
MsgBox "done", vbOKOnly, "done"
End Sub
Any help on how to add ???= Sheets("Sheet1") and ??? = Sheets("Sheet3")
would help me a great deal. Thanks
You might want to consider discarding the laborious task of looping through every cell while comparing it to every other and use a pair of conditional formatting rules.
Option Explicit
Private Sub cfrS1S3dupes()
With ThisWorkbook.Worksheets("sheet1")
With .Range(.Cells(2, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "J"))
'get rid of pre-existing cfrs
.FormatConditions.Delete
'if duplicate in sheet1 found below row, then fill red
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=countifs($a$2:$a2, $a2, $h$2:$h2, $h2, $j$2:$j2, $j2)>1")
.Interior.Color = 255 'this is the color red
End With
'if duplicate anywhere in sheet3, then fill green
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=countifs(sheet3!$a:$a, $a2, sheet3!$h:$h, $h2, sheet3!$j:$j, $j2)")
.Interior.Color = 5287936 'this is the color green
End With
End With
End With
End Sub
First of all, you should declare 2 sheet objects to make it easier to read and future code maintences easier:
Dim ws1 As Worksheet
Dim ws2 As Worksheet
'use this approach if your sheet's name is dinamic but never changes it's order
'Set ws1 = ThisWorkbook.Sheets(1)
'Set ws2 = ThisWorkbook.Sheets(2)
'use this if name is static
Set ws1 = ThisWorkbook.Sheets("name of worksheet1")
Set ws2 = ThisWorkbook.Sheets("name of worksheet2")
Then just put the Sheets objects in their specific locations like this (pay attention to the 'ws1's and 'ws2's):
Dim StudentID As String
Dim DT As String
Dim Description As String
Do While (ws1.Range("A" & Row).Value <> "")
innerRow = Row + 1
StudentID = ws1.Range("A" & Row).Value
DT = ws1.Range("H" & Row).Value
Description = ws1.Range("J" & Row).Value
Do While (ws2.Range("A" & innerRow).Value <> "")
If (ws2.Range("A" & innerRow).Value = StudentID And ws2.Range("H" & innerRow).Value = DT And ws2.Range("J" & innerRow).Value = Description) Then
'not sure what you are trying to do with this 3 lines, change it for your own needs
ws1.Range("X" & Row).Value = ws2.Range("X" & Row).Value & innerRow & ", "
ws1.Range("X" & innerRow).Value = ws2.Range("X" & innerRow).Value & Row & ", "
ws1.Rows(Row).Interior.ColorIndex = 6
ws1.Rows(innerRow).Interior.ColorIndex = 6
End If
innerRow = innerRow + 1
Loop
Row = Row + 1
Loop
End Sub
ps: i couldn't test it since you didn't provide the base of yours. But since you said you can read code and understand it's logic, I think you'll be fine :)
This is a follow on from How do I get all the different unique combinations of 3 columns using VBA in Excel?
It almost what i need, however, my requirements is that it sums the third column which will contain figures instead of yes/no
Sub sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim col As New Collection
Dim Itm
Dim cField As String
Const deLim As String = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
cField = .Range("A" & i).Value & deLim & _
.Range("B" & i).Value & deLim & _
.Range("C" & i).Value
On Error Resume Next
col.Add cField, CStr(cField)
On Error GoTo 0
Next i
i = 2
.Range("A1:C1").Copy .Range("F1")
.Range("I1").Value = "Count"
For Each Itm In col
.Range("F" & i).Value = Split(Itm, deLim)(0)
.Range("G" & i).Value = Split(Itm, deLim)(1)
.Range("H" & i).Value = Split(Itm, deLim)(2)
For j = 2 To lRow
cField = .Range("A" & j).Value & deLim & _
.Range("B" & j).Value & deLim & _
.Range("C" & j).Value
If Itm = cField Then nCount = nCount + 1
Next
.Range("I" & i).Value = nCount
i = i + 1
nCount = 0
Next Itm
End With
End Sub
This code was originally added by
Siddharth Rout
try this (follows comments)
Option Explicit
Sub Main()
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = 4 To Range("A" & Rows.Count).End(xlUp).Row '<-- change 4 and "A" to your data actual upleftmost cell row and column
dict(cells(i, 1).Value & "|" & cells(i, 2).Value) = dict(cells(i, 1).Value & "|" & cells(i, 2).Value) + cells(i, 3).Value '<--| change 3 to your actual "column to sum up" index
Next
With Range("G3").Resize(dict.Count) '<-- change "G3" to your actual upleftmost cell to start writing output data from
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items) '<--| change 2 to your actual column offset where to start writing summed values form
End With
End Sub