How do I transpose the output in the code below?
Dim lastRow As Range, rng1 As Range
Set rng1 = Worksheets(1).Range("I80:I83")
Set lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(ThisWorkbook.Worksheets("Sheet1").Rows.Count, "B").End(xlUp)
lastRow.Offset(1, 0).Resize(rng1.Rows.Count, rng1.Columns.Count) = rng1.Value
It should work. Consider the following example: (can't fit to comment)
With Sheet1 '/* or what ever your sheet object is */
.Range("A1") = 1
.Range("A2") = 2
.Range("A3") = 3
.Range("C1:E1") = Application.Transpose(.Range("A1:A3"))
End With
Applying to your code:
Dim lastRow As Range, rng1 As Range
With Thisworkbook.Sheets(1)
Set rng1 = .Range("I80:I83")
Set lastrow = .Range("B" & .Rows.Count).End(xlUp)
lastrow.Offset(1, 0).Resize(rng1.Columns.Count, rng1.Rows.Count) = rng1.Value
End With
Related
In the code below, I have identified a range (ColRng) in which I want to check each cell - if it is empty, there is a SUMIFS function to perform. It does not work. I know my syntax and logic is horrid, but I can't figure out how to make it work.
Dim ColRng As Range
Dim LastCol As Long
Dim LastRowScenario As Long
Dim x As Long
Dim rngCrit1 As Range
Dim rngCrit2 As Range
Dim rngSum As Range
LastRowScenario = Sheets("Sheet1").Range("Q2").End(xlDown).Row
Set rngCrit1 = Sheets("Sheet1").Range("D2:D" & LastRowScenario)
Set rngCrit2 = Sheets("Sheet1").Range("B2:B" & LastRowScenario)
Set rngSum = Sheets("Sheet1").Range("Q2:Q" & LastRowScenario)
LastCol = Sheets("Summary").Range("B5").End(xlToRight).Column
Set ColRng = Range(LastCol & "6:" & LastCol & "149")
For x = ColRng.Cells.Count To 1 Step -1
With ColRng.Cells(x)
' If the cell is empty, perform a SUMIFS
If IsEmpty(.Value) Then
.Formula = Application.WorksheetFunction.SumIfs(rngSum, rngCrit1, .Range("E" & .Row).Value, rngCrit2, .Range("B" & .Row).Value)
End If
End With
Next x
Your ColRng construction is wrong - try something like this instead:
Dim ColRng As Range
Dim LastCol As Long
Dim LastRowScenario As Long
Dim x As Long
Dim rngCrit1 As Range
Dim rngCrit2 As Range
Dim rngSum As Range, ws As Worksheet, wsSumm As Worksheet
set ws = Sheets("Sheet1")
Set rngSum = ws.Range("Q2:Q" & ws.Range("Q2").End(xlDown).Row)
Set rngCrit1 = rngSum.EntireRow.Columns("D")
Set rngCrit2 = rngSum.EntireRow.Columns("B")
Set wsSumm = Sheets("Summary")
With wsSumm.Range("B5").End(xlToRight).EntireColumn
Set ColRng = wsSumm.Range(.Cells(6), .Cells(149))
End With
For x = ColRng.Cells.Count To 1 Step -1
With ColRng.Cells(x)
' If the cell is empty, perform a SUMIFS
If IsEmpty(.Value) Then
.Formula = Application.SumIfs(rngSum, _
rngCrit1, .EntireRow.columns("E").Value, _
rngCrit2, .EntireRow.columns("B").Value)
End If
End With
Next x
I have been trying to make a function where it matches 2 separate strings with two column then copy corresponding columns data and paste into separate sheet.
I am stuck on that thing how to make 2 matches like For Each cell In myDataRng & myDataRng2.
your help will be appreciated
Sub Tester()
Dim myDataRng, myDataRng2 As Range
Dim cell As Range, wsSrc As Worksheet, wsDest As Worksheet
Dim destRow As Range
Dim FindValue As String
Dim FindValue2 As String
Set wsSrc = Worksheets("Sheet1") 'source sheet
Set wsDest = Worksheets("Sheet2") 'destination sheet
FindValue = wsDest.Range("A2").Value
FindValue2 = wsDest.Range("B2").Value
Set myDataRng = wsSrc.Range("F2:F" & wsSrc.Cells(Rows.Count, "F").End(xlUp).Row)
Set myDataRng2 = wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, "A").End(xlUp).Row)
Set destRow = wsDest.Rows(2) 'first destination row
For Each cell In myDataRng
If InStr(1, cell.Value, FindValue) > 0 Then
With cell.EntireRow 'the whole matching row
destRow.Cells(5).Value = .Cells(2).Value
destRow.Cells(6).Value = .Cells(3).Value
destRow.Cells(7).Value = .Cells(4).Value
destRow.Cells(8).Value = .Cells(5).Value
End With
Set destRow = destRow.Offset(1, 0) 'next destination row
End If
Next cell
End Sub
Other Condition
Sub find()
Dim foundRng As Range
Dim mValue As String
Set shData = Worksheets("Sheet1")
Set shSummary = Worksheets("Sheet2")
mValue = shSummary.Range("C2")
Set foundRng = shData.Range("G1:Z1").find(mValue)
'If matches then copy macthed Column and paste into Sheet2 Col"I" (as above code psting the data into Sheet2)
End Sub
Several options:
If Instr(1, cell.Offset(,-5).Value, FindValue2) > 0 Then
If InStr(1, wsSrc.Range("A" & cell.Row), FindValue2) > 0 Then
and others.
I like using rows for loops like this because it makes it very easy to read the code and understand what is happening. By breaking the search range into a series of rows, everything becomes simple to write and read.
Sub Tester()
Dim myDataRng, myDataRng2 As Range
Dim rRow As Range, wsSrc As Worksheet, wsDest As Worksheet
Dim destRow As Range
Dim FindValue As String
Dim FindValue2 As String
Set wsSrc = Worksheets("Sheet1") 'source sheet
Set wsDest = Worksheets("Sheet2") 'destination sheet
FindValue = wsDest.Range("A2").Value
FindValue2 = wsDest.Range("B2").Value
Set myDataRng = wsSrc.Range("F2:F" & wsSrc.Cells(Rows.Count, "F").End(xlUp).Row)
'Set myDataRng2 = wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, "A").End(xlUp).Row)
Set destRow = wsDest.Rows(2) 'first destination row
For Each rRow In myDataRng.Rows.EntireRow
If InStr(1, rRow.Columns("F").Value, FindValue) > 0 _
And InStr(1, rRow.Columns("A").Value, FindValue2) > 0 Then
With rRow.EntireRow 'the whole matching row
destRow.Cells(5).Value = .Cells(2).Value
destRow.Cells(6).Value = .Cells(3).Value
destRow.Cells(7).Value = .Cells(4).Value
destRow.Cells(8).Value = .Cells(5).Value
End With
Set destRow = destRow.Offset(1, 0) 'next destination row
End If
Next rRow
End Sub
Set wsSrc = Worksheets("Sheet1") 'source sheet
Set wsDest = Worksheets("Sheet2") 'destination sheet
FindValue = wsDest.Range("A2").Value
FindValue2 = wsDest.Range("B2").Value
Set myDataRng = wsSrc.Range("F2:F" & wsSrc.Cells(Rows.Count, "F").End(xlUp).Row)
'Set myDataRng2 = wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, "A").End(xlUp).Row)
Set destRow = wsDest.Rows(2) 'first destination row
For Each rRow In myDataRng.Rows
If InStr(1, rRow.Columns("F").Value, FindValue) > 0 _
And InStr(1, rRow.Columns("A").Value, FindValue2) > 0 Then
With rRow.EntireRow 'the whole matching row
destRow.Cells(5).Value = .Cells(2).Value
destRow.Cells(6).Value = .Cells(3).Value
destRow.Cells(7).Value = .Cells(4).Value
destRow.Cells(8).Value = .Cells(5).Value
End With
Set destRow = destRow.Offset(1, 0) 'next destination row
End If
Next rRow
End Sub
I want to retrieve data in a row with the name and the header.
I really appreciate your help
NAME AUG 1, 2019 AUG 2, 2019 AUG 3, 2019
Zoldyk,Hunter 5 7
Luffy,One 1 2 3
Sub Button1_Click()
Dim rngCopy As Range, rngTemp As Range, rngTarget As Range
Dim intMultiple As Integer, i As Integer, intRow As Integer
Dim objSheet As Worksheet
Set objSheet = Sheets(1)
Dim intLastCellIndexInRow As Integer
intLastCellIndexInRow = ActiveCell.SpecialCells(xlLastCell).Column
Dim strRowValue As String
Dim j As Integer
Set rngCopy = Sheet1.Range("A2", Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp)) 'Set range including names
Set rngTarget = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1, 0) 'Set target range to next available row in Sheet2
`For intRow = rngCopy.Rows.Count To 1 Step -1
Set rngTemp = rngCopy.Cells(intRow)
intMultiple = rngTemp.Offset(0, 1) 'Find how many times to copy the name
For i = 1 To intMultiple
For j = 3 To intLastCellIndexInRow
rngTarget.Value = rngTemp.Value 'Copy name
rngTarget.Next.Value = objSheet.Cells(ActiveCell.Row, j) 'Copy ID
Set rngTarget = rngTarget.Offset(1, 0) 'Move target range to next row
Next
Next
Next
End Sub
Zoldyk,hunter|5|aug 1,2019
Zoldyk,hunter| |aug 2,2019
Zoldyk,hunter|7|aug 3,2019
Luffy,One |1|aug 1,2019
Luffy,One |2|aug 2,2019
Luffy,One |3|aug 3,2019
Notes:
Didn't understand your loop,so I have changed it completely
Try and remove the extra declarations that are left in the code.
You can manipulate it to print on other sheet.
You can also use Pivot for this.
Use the Below code :
Sub Button1_Click()
Dim rngCopy As Range, rngTemp As Range, rngTarget As Range
Dim intMultiple As Integer, i As Integer, intRow As Integer
Dim objSheet As Worksheet
Set objSheet = Sheets(1)
Dim strRowValue As String
Dim j As Integer
Dim cl As Integer
Set rngCopy = Sheet1.Range("A2", Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp)) 'Set range including names
Set rngTarget = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1, 0) 'Set target range to next available row in Sheet2\
cl = Sheet1.Range("A1").End(xlToRight).Column
i = rngTarget.row
For Each cel In rngCopy.Cells
For j = 2 To cl
With Sheet1
.Range("A" & i).Value = cel.Value
.Range("B" & i).Value = .Cells(cel.row, j).Value
.Range("C" & i).Value = .Cells(1, j).Value
i = i + 1
End With
Next
Next
End Sub
Demo:
Sub CompareAndHighlight()
Dim xRange As Range, yRange As Range
Dim xCell As Range, yCell As Range
Dim Found As Range
Dim wsX As Worksheet: Set wsX = ThisWorkbook.Sheets("Sheet1")
Dim wsY As Worksheet: Set wsY = ThisWorkbook.Sheets("Sheet2")
LR1 = wsX.Range("A" & wsX.Rows.Count).End(xlUp).Row
LR2 = wsY.Range("A" & wsY.Rows.Count).End(xlUp).Row
Set xRange = wsX.Range("A1:A" & LR1)
Set yRange = wsY.Range("A1:A" & LR2)
For Each xCell In xRange
Set Found = yRange.Find(xCell.Value)
If Found Is Nothing Then
xCell.Interior.Color = RGB(255, 0, 0)
End If
Set Found = Nothing
Next xCell
End Sub
I use above code to compare two excel sheets. i do comparison only between only column "A".
What I want to do is compare other column sequentially like compare further "B" to "b" and "c" to "c".
how can i do that by changing the code.
I like to use the sheet.cells() destination so you can easily use integers to call out both rows and columns
Sub CompareAndHighlight()
Dim xRange, yRange, xCell, yCell, Found As Range
Dim i, LR1, LR2 As Integer
Dim wsX As Worksheet: Set wsX = ThisWorkbook.Sheets("Sheet1")
Dim wsY As Worksheet: Set wsY = ThisWorkbook.Sheets("Sheet2")
For i = 1 To 3 'Set to the number of the last column you want to run the comparison
LR1 = wsX.Cells(wsX.Rows.Count, i).End(xlUp).Row
LR2 = wsY.Cells(wsY.Rows.Count, i).End(xlUp).Row
Set xRange = wsX.Range(wsX.Cells(1, i), wsX.Cells(LR1, i))
Set yRange = wsY.Range(wsY.Cells(1, i), wsY.Cells(LR2, i))
For Each xCell In xRange
Set Found = yRange.Find(xCell.Value)
If Found Is Nothing Then
xCell.Interior.Color = RGB(255, 0, 0)
End If
Set Found = Nothing
Next xCell
Next i
End Sub
Modify if needed and try:
Option Explicit
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngToSearch As Range, FindPosition As Range
Dim Lastrow1 As Long, Lastrow2 As Long, ColumnToSearch As Long, i As Long, y As Long
Dim strToSearch As String
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Lastrow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
Lastrow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow1
For y = 1 To 3
strToSearch = ws1.Cells(i, y).Value
If y = 1 Then
ColumnToSearch = 1
ElseIf y = 2 Then
ColumnToSearch = 2
ElseIf y = 3 Then
ColumnToSearch = 3
End If
Set rngToSearch = ws2.Range(ws2.Cells(1, ColumnToSearch), ws2.Cells(Lastrow2, ColumnToSearch))
Set FindPosition = rngToSearch.Find(strToSearch)
If FindPosition Is Nothing Then
ws1.Cells(i, y).Interior.Color = RGB(255, 0, 0)
End If
Next y
Next i
End Sub
I am using code below which I am trying to change so as not to use .select
Selection.Select ' from active worksheet
Selection.Copy
Sheets("Purch Req").Select
Range("A1").Select
ActiveSheet.Paste
I have tried using this but there is no output to the other worksheet.
Dim src2Range As Range, dest2Range As Range
Set src2Range = Selection 'source from selected range
Set dest2Range = Sheets("Purch Req").Range("A1").Resize(src2Range.Rows.Count, src2Range.Columns.Count) ' destination range _
'in Purch req worksheet
Here is good examples on How to avoid using Select in Excel VBA Link stackoverflow
Here is simples of
copy/paste - values = values - PasteSpecial method
Option Explicit
'// values between cell's
Sub PasteValues()
Dim Rng1 As Range
Dim Rng2 As Range
Set Rng1 = Range("A1")
Set Rng2 = Range("A2")
Rng2.Value = Rng1.Value
'or
[A2].Value = [A1].Value
'or
Range("A2").Value = Range("A1").Value
'or
Set Rng1 = Range("A1:A3")
Set Rng2 = Range("A1:A3")
Rng2("B1:B3").Value = Rng1("A1:A3").Value
'or
[B1:B3].Value = [A1:A3].Value
'// values between WorkSheets
Dim xlWs1 As Worksheet
Dim xlWs2 As Worksheet
Set xlWs1 = Worksheets("Sheet1")
Set Rng1 = xlWs1.Range("A1")
Set xlWs2 = Worksheets("Sheet2")
Set Rng2 = xlWs2.Range("A1")
Rng2.Value = Rng1.Value
'or
Set Rng1 = [=Sheet1!A1]
Set Rng2 = [=Sheet2!A1]
Rng2.Value = Rng1.Value
'or
[=Sheet2!A1].Value = [=Sheet1!A1].Value
'or
Worksheets("Sheet2").Range("A2").Value = Worksheets("Sheet1").Range("A1").Value
'// values between workbooks
Dim xlBk1 As Workbook
Dim xlBk2 As Workbook
Set xlBk1 = Workbooks("Book1.xlsm")
Set Rng1 = xlBk1.Worksheets("Sheet1").Range("A1")
Set xlBk2 = Workbooks("Book2.xlsm")
Set Rng2 = xlBk2.Worksheets("Sheet1").Range("A1")
Rng2.Value = Rng1.Value
'or
Set Rng1 = Evaluate("[Book1.xlsm]Sheet1!A1")
Set Rng2 = Evaluate("[Book2.xlsm]Sheet2!A1")
Rng2.Value = Rng1.Value
'or
Evaluate("[Book2.xlsm]Sheet2!A1").Value = Evaluate("[Book1.xlsm]Sheet1!A1")
'or
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").Value = _
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Value
End Sub
Simple copy/paste
Sub CopyRange()
Dim Rng1 As Range
Dim Rng2 As Range
Set Rng1 = Range("A1")
Set Rng2 = Range("A2")
Rng1.Copy Rng2
[A1].Copy [A2]
Range("A2").Copy Range("A1")
'// Range.Copy to other worksheets
Dim xlWs1 As Worksheet
Dim xlWs2 As Worksheet
Set xlWs1 = Worksheets("Sheet1")
Set Rng1 = xlWs1.Range("A1")
Set xlWs2 = Worksheets("Sheet2")
Set Rng2 = xlWs2.Range("A1")
Rng1.Copy Rng2
Set Rng1 = [=Sheet1!A1]
Set Rng2 = [=Sheet2!A1]
Rng1.Copy Rng2
[=Sheet1!A1].Copy [=Sheet2!A1]
Worksheets("Sheet1").Range("A1").Copy Worksheets("Sheet2").Range("A1")
''// Range.Copy to other workbooks
Dim xlBk1 As Workbook
Dim xlBk2 As Workbook
Set xlBk1 = Workbooks("Book1.xlsm")
Set Rng1 = xlBk1.Worksheets("Sheet1").Range("A1")
Set xlBk2 = Workbooks("Book2.xlsm")
Set Rng2 = xlBk2.Worksheets("Sheet2").Range("A2")
Rng1.Copy Rng2
Evaluate("[Book1.xlsm]Sheet1!A1").Copy Evaluate("[Book2.xlsm]Sheet2!A2")
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Copy _
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1")
End Sub
PasteSpecial method
Sub PasteSpecial()
'Copy and PasteSpecial a Range
Range("A1").Copy
Range("A3").PasteSpecial Paste:=xlPasteFormats
'Copy and PasteSpecial a between worksheets
Worksheets("Sheet1").Range("A2").Copy
Worksheets("Sheet2").Range("A2").PasteSpecial Paste:=xlPasteFormulas
'Copy and PasteSpecial between workbooks
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Copy
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End Sub
There is many ways to do that, but here goes two.
1)
Sub pasteExcel()
Dim src2Range As Range
Dim dest2Range As Range
Dim r 'to store the last row
Dim c 'to store the las column
Set src2Range = Selection 'source from selected range
r = Range("A1").End(xlDown).Row 'Get the last row from A1 to down
c = Range("A1").End(xlToRight).Column 'Get the last Column from A1 to right
Set dest2Range = Range(Cells(1, 1), Cells(r, c))
dest2Range.PasteSpecial xlPasteAll
Application.CutCopyMode = False 'Always use the sentence.
End Sub
2)
Sub pasteExcel2()
Dim sht1 As Worksheet
Dim sht2 As Worksheet 'not used!
Dim src2Range As Range
Dim dest2Range As Range
Dim r 'to store the last row
Dim c 'to store the las column
Set sht1 = Sheets("Sheet1")
Set sht2 = Sheets("Sheet2")
sht1.Activate 'Just in case... but not necesary
r = Range("A1").End(xlDown).Row 'Get the last row from A1 to down
c = Range("A1").End(xlToRight).Column 'Get the last Column from A1 to right
Set src2Range = Range(Cells(1, 1), Cells(r, c)) 'source from selected range
Set dest2Range = Range(Cells(1, 1), Cells(r, c))
sht2.Range(dest2Range.Address).Value = src2Range.Value 'the same range in the other sheet.
End Sub
Tell me if you need some improvement.