Related
The code that I have currently pastes the data in Column A of worksheet "Projects" into the next blank row on worksheet "Assignment". I would like it to paste into the first blank cell on worksheet "Assignment" instead.
Option Explicit
Sub CopyPasteX()
'Declare variables
Dim projName As String
Dim projCount As Integer, lRow As Integer, lRow2 As Integer, i As Integer, j As Integer
'Find last row
lRow = Sheets("Projects").Range("A" & Rows.Count).End(xlUp).Row
'Begin loop - CHANGE BELOW FROM 2 TO 1 IF SPREADSHEET DOES NOT INCLUDE HEADDERS
For i = 2 To lRow
'Set project names and the project count
projName = Sheets("Projects").Range("A" & i)
projCount = Sheets("Projects").Range("B" & i)
'Second loop for pasting in project
For j = 1 To projCount
'Find last row on sheet 2
lRow2 = Sheets("Assignment").Range("A" & Rows.Count).End(xlUp).Row
'Paste in the project name on sheet2
Sheets("Assignment").Range("A" & lRow2 + 1).Value = projName
'Loop to continue copying based on the project count
Next j
'Loop to next project
Next i
End Sub
Edit: I amended the lRow2 definition and refactored the whole code to take advantage of With ... End With sintax and reference proper sheet
Sub CopyPasteX()
'Declare variables
Dim lRow2 As Integer, j As Long
Dim cell As Range
With Sheets("Projects") 'reference wanted sheet
'loop through referenced sheet column A cells from row 1 down to last not empty one
'Begin loop - CHANGE BELOW FROM "A2" TO "A1" IF SPREADSHEET DOES NOT INCLUDE HEADDERS
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Second loop for pasting in project, taking current cell adjacent one as the ending value
For j = 1 To cell.Offset(, 1)
'Find firts empty cell on sheet Assignment
With Sheets("Assignment")
Select Case True
Case IsEmpty(.Range("A1"))
lRow2 = 0
Case WorksheetFunction.CountA(.Range("A1", .Cells(.Rows.Count, "A").End(xlUp))) = 1
lRow2 = 1
Case Else
lRow2 = .Range("A1").End(xlDown).row
End Select
.Range("A" & lRow2 + 1).Value = cell.Value 'Paste current cell value (i.e. project name) in referenced sheet column A at row lRow
End With
'Loop to continue copying based on the project count
Next
'Loop to next project
Next
End With
End Sub
'Find last row on sheet 2
lRow2 = Sheets("Assignment").[A1].End(xlDown).Row
I found that this works exactly how I need it to.
Edit: This does not work as noted in the reply.
No need for inner loop. Try this code
Sub CopyPasteX()
Dim projName As String
Dim projCount As Integer
Dim lRow As Integer
Dim lRow2 As Integer
Dim i As Integer
lRow = Sheets("Projects").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
projName = Sheets("Projects").Range("A" & i)
projCount = Sheets("Projects").Range("B" & i)
lRow2 = Sheets("Assignment").Range("A" & Rows.Count).End(xlUp).Row
lRow2 = IIf(lRow2 = 1, 1, lRow2 + 1)
Sheets("Assignment").Range("A" & lRow2).Resize(projCount).Value = projName
Next i
End Sub
Another code (using arrays)
Sub Test()
Dim arr As Variant
Dim temp() As String
Dim i As Long
Dim j As Long
Dim k As Long
arr = Sheets("Projects").Range("A2:B" & Sheets("Projects").Cells(Rows.Count, 1).End(xlUp).Row).Value
j = 1: k = 1
For i = 1 To UBound(arr, 1)
k = k + arr(i, 2)
ReDim Preserve temp(1 To k)
For j = j To k
temp(j) = arr(i, 1)
Next j
j = k
Next i
With Sheets("Assignment").Range("A1")
.Resize(k - 1, 1).Value = Application.Transpose(temp)
End With
End Sub
I have two spreadsheets (wb and wbtemp); both have a column for location and a column for feature type. In VBA, I want to find all of the rows on the second sheet where the two columns are the same as the two columns on a row in the first sheet and get a list or a range made up of the row numbers/indices.
I then want to use this range to pull out values from a different column and find the highest object in it, but I think I will probably be able to do that if I can get this range sorted.
Dim wb As Workbook
Dim ws As Worksheet
Dim Features() As Variant
Dim Activity() As Variant
Dim Benthic As Variant
Dim wbtemp As Workbook
Dim BenSenFeatures() As Variant
Dim BenSenActivity() As Variant
Dim LR As Long
Dim LC As Long
Dim r As Long
Dim c As Long
Dim WhatToFind1 As Variant
Dim WhatToFind2 As Variant
Dim rngFound1 As Range
Dim rngFound2 As Range
Dim rng1 As Variant
Dim rng2 As Variant
Dim rngFound As Range
Dim iLoop As Long
Dim colFound As Range
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Features = ws.Range("B:C").Value
Activity = ws.Rows(1).Value
Benthic = InputBox("Filename goes here...")
Set wbtemp = Workbooks.Open(Benthic, True, True)
With wbtemp
BenSenFeatures = .Sheets(1).Range("A:B").Value
BenSenActivity = .Sheets(1).Rows(1).Value
End With
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
LC = ws.Cells(1, Columns.Count).End(xlToLeft).Column
For r = 3 To LR
If Not IsEmpty(Features(r, 2)) Then
If IsInArray(Features(r, 2), BenSenFeatures, 2) Then
'If WorksheetFunction.Match(Features(r, 2), BenSenFeatures(0, 2), 0) Then <---I tried to use the arrays originally
WhatToFind1 = Features(r, 1)
WhatToFind2 = Features(r, 2)
Set rngFound1 = wbtemp.Sheets(1).Columns(1).Cells(wbtemp.Sheets(1).Columns(1).Cells.Count)
Set rngFound2 = wbtemp.Sheets(1).Columns(2).Cells(wbtemp.Sheets(1).Columns(2).Cells.Count)
For iLoop = 1 To WorksheetFunction.CountIf(wbtemp.Sheets(1).Columns(1), WhatToFind1)
Set rngFound1 = wbtemp.Sheets(1).Columns(1).Cells.Find(WhatToFind1, After:=rngFound1)
rng1(iLoop) = rngFound1.Row
'WorksheetFunction.Index(wbtemp.Sheets(1).Range("A:B").Value,_
WorksheetFunction.Match(WhatToFind1 & WhatToFind2,_
wbtemp.Sheets(1).Columns(1) & wbtemp.Sheets(1).Columns(2),_
0), 1) <---originally tried to use match to search for the multiple criteria but couldn't find a way to create a list of indices
Set rngFound2 = wbtemp.Sheets(1).Columns(2).Cells.Find(WhatToFind2, After:=rngFound2)
rng2(iLoop) = rngFound2.Row
Next iLoop
For Each cell In rng1
If Not Application.CountIf(rng2, cell.Value) = 0 Then
rngFound.Cells(Cells(Rows.Count, 1).End(xlUp) + 1) = cell.Value
End If
Next
I originally tried to use .Match to find the multiple criteria, but I couldn't figure out how to create a range of indices from it. Then I tried using .Find to create two list of indices but I can't figure out how to get that to work. I keep getting
Type Mismatch
errors.
I realise this sounds confusing, so let me know if anything needs clarifying.
Something like this should work for you. I tried to comment the code for clarity.
Sub tgr()
Dim wb As Workbook
Dim ws As Worksheet
Dim rData As Range
Dim wbTemp As Workbook
Dim wsTemp As Worksheet
Dim rTempData As Range
Dim aData() As Variant
Dim aTempData() As Variant
Dim aResults() As Variant
Dim lNumResults As Long
Dim DataIndex As Long, TempIndex As Long, ResultIndex As Long, j As Long
Dim sCritRange1 As String, sCritRange2 As String
Dim sCriteria1 As String, sCriteria2 As String
Set wb = ActiveWorkbook
'Adjust these two as necessary
Set ws = wb.Sheets(1)
Set rData = ws.Range("B3", ws.Cells(ws.Rows.Count, "B").End(xlUp))
'Select wbTemp file
On Error Resume Next
Set wbTemp = Workbooks.Open(Application.GetOpenFilename("Excel Files, *.xls*"))
On Error GoTo 0
If wbTemp Is Nothing Then Exit Sub 'Pressed cancel
'Adjust these two as necessary
Set wsTemp = wbTemp.Sheets(1)
Set rTempData = wsTemp.Range("A1", wsTemp.Cells(wsTemp.Rows.Count, "A").End(xlUp))
sCritRange1 = rTempData.EntireColumn.Address(external:=True)
sCritRange2 = rTempData.Offset(, 1).EntireColumn.Address(external:=True)
sCriteria1 = rData.Address(external:=True)
sCriteria2 = rData.Offset(, 1).Address(external:=True)
lNumResults = Evaluate("SUMPRODUCT(COUNTIFS(" & sCritRange1 & "," & sCriteria1 & "," & sCritRange2 & "," & sCriteria2 & "))")
If lNumResults = 0 Then Exit Sub 'No matches
ReDim aResults(1 To lNumResults, 1 To 3)
aData = rData.Resize(, 2).Value
aTempData = rTempData.Resize(, 2).Value
'Loop through both data ranges
For DataIndex = LBound(aData, 1) To UBound(aData, 1)
For TempIndex = LBound(aTempData, 1) To UBound(aTempData, 1)
'Find where both criteria matches
If aTempData(TempIndex, 1) = aData(DataIndex, 1) And aTempData(TempIndex, 2) = aData(DataIndex, 2) Then
'Match found, add to results and collect the row index
ResultIndex = ResultIndex + 1
aResults(ResultIndex, 1) = aData(DataIndex, 1)
aResults(ResultIndex, 2) = aData(DataIndex, 2)
aResults(ResultIndex, 3) = "Row: " & TempIndex + rTempData.Row - 1 'This is the row index from wsTemp of the found match
End If
Next TempIndex
Next DataIndex
'Row index results gathered
'Do what you want with the results
'In this example it is just providing msgboxes displaying the results
For ResultIndex = LBound(aResults, 1) To UBound(aResults, 1)
MsgBox "Location: " & aResults(ResultIndex, 1) & Chr(10) & _
"Feature: " & aResults(ResultIndex, 2) & Chr(10) & _
"RowIndex: " & aResults(ResultIndex, 3)
Next ResultIndex
'Close wbTemp
wbTemp.Close
End Sub
I made some minor modifications to tigeravatar's answer to get it to work with my data:
Mainly creating a loop which cycled through each row in wb so that the criteria used with CountIfs was a single value and not a range of values.
I swapped the Evaluate("SUMPRODUCT(COUNTIFS(" & sCritRange1 & "," & sCriteria1 & "," & sCritRange2 & "," & sCriteria2 & "))") for Application.WorksheetFunction.CountIfs(Range(sCritRange1), Range(sCriteria1).Value, Range(sCritRange2), Range(sCriteria2).Value)
I would like to thank tigeravatar for their help.
LR = ws.Range("C" & Rows.Count).End(xlUp).Row
LC = ws.Cells(1, Columns.Count).End(xlToLeft).Column
For r = 3 To LR
sCritRange1 = rTempData.EntireColumn.Address(external:=True)
sCritRange2 = rTempData.Offset(, 1).EntireColumn.Address(external:=True)
sCriteria1 = rData(r, 1).Address(external:=True)
sCriteria2 = rData(r, 1).Offset(, 1).Address(external:=True)
lNumResults = Application.WorksheetFunction.CountIfs(Range(sCritRange1), Range(sCriteria1).Value, Range(sCritRange2), Range(sCriteria2).Value)
If lNumResults = 0 Then Exit Sub 'No matches
ReDim aResults(1 To lNumResults, 1 To 3)
aData = rData(r, 1).Resize(, 2).Value
aTempData = rTempData.Resize(, 2).Value
'Loop through both data ranges
For DataIndex = LBound(aData, 1) To UBound(aData, 1)
For TempIndex = LBound(aTempData, 1) To UBound(aTempData, 1)
'Find where both criteria matches
If Not IsEmpty(aTempData(TempIndex, 1)) Then
If aTempData(TempIndex, 1) = aData(DataIndex, 1) And aTempData(TempIndex, 2) = aData(DataIndex, 2) Then
'Match found, add to results and collect the row index
ResultIndex = ResultIndex + 1
aResults(ResultIndex, 1) = aData(DataIndex, 1)
aResults(ResultIndex, 2) = aData(DataIndex, 2)
aResults(ResultIndex, 3) = "Row: " & TempIndex + rTempData.Row - 1 'This is the row index from wsTemp of the found match
End If
End If
Next TempIndex
Next DataIndex
Next r
I have an output excel file from another macro which has multiple sheets (named 100,101,102... etc.) Sheet numbers will vary depending on prior macro's output.
Also there is a sheet named sheet1 which has info about how many random rows should be selected from 100,101,102... etc.
I tried to merge/combine what i could find from similar macros but i guess the loop part is way over my head.
I will run the macro from another "main" excel. which will open related output xls.
Then it will lookup for random rows amount from sheet1 and then select that number of random rows in related sheet and move to next sheet. (I'm getting the correct amount from lookup (used index match))
But for randomized part i was not able to make it work for multiple sheets.
It does not matter if it selects and colors the rows or copies and pastes them to another sheet/wb. Both is ok, but I need to automate this process since i have so much data waiting.
The macro i have managed so far is below, since I'm a newbie there may be unrelated or unnecessary things.
Is it possible?
Sub RANDOM()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
Dim Durat As Long
StartTime = Now()
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Integer
Dim I As Long
FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" &
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value
& " Muavinbol" & ".xls")
SheetN = mvn.Worksheets.Count
Set SampleS = mvn.Sheets("Sheet1")
For Each Sh In mvn.Worksheets
Sh.Activate
If Sh.Name <> "Sheet1" Then
Dim lookupvalue As Integer
Dim ranrows As Integer
Dim randrows As Integer
lookupvalue = Cells(1, 1).Value
ranrows = Application.WorksheetFunction.Index(mvn.Sheets("Sheet1")_
.Range("S1:S304"), Application.WorksheetFunction.Match(lookupvalue,
mvn.Sheets("Sheet1").Range("$D$1:$D$304"), 0))
'MsgBox lookupvalue & " " & ranrows
End If
Next Sh
Durat = Round((Now() - StartTime) * 24 * 60 * 60, 0)
'MsgBox Durat & " seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Here is an example (i have integrated some code, adapted from other places, and added the references in to the code itself) I would welcome feedback from other users and can refine.
Sheet1 has the number of rows to return and the sheet names (i have used a short list)
The other sheets have some random data e.g. Sheet2
The code reads the sheet names into one array and the number of rows to randomly choose from each sheet into another array.
It then loops the sheets, generates the number of required random rows by selecting between the first and the start row in the sheet (this currently doesn't have error handling in case specified number of random rows exceeds available number ,but then could set numRows to lastRow. Union is used to collect these for the given sheet and they are copied to the next available row in the target sheet of another workbook. Union can't be used across worksheets sadly so a workaround has to be found, i chose this copy for each worksheet.
I have made some assumptions about where to copy from and to but have a play. I have also left some of your code in and currently set mnv = ThisWorkbook and the workbook to copy to is called otherWorkbook. Yours may be differently named and targeted but this was aimed at showing you a process for generating numbers and copying them in a loop.
Have used a function by Rory to test if the worksheet exists.
Example result:
Option Explicit
Public Sub RANDOM()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Sh As Worksheet
Dim Durat As Long
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
'Dim SheetN As Long
Dim i As Long
Dim otherWorkbook As Workbook
Dim targetSheet As Worksheet
Dim startTime As Date
Dim mnv As Workbook
Dim SampleS As Worksheet
startTime = Now()
FPath = ThisWorkbook.Path
'Set mvn = Workbooks.Open(Filename:=ActiveWorkbook.Path & "\" & Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value & " Muavinbol" & ".xls")
Set mnv = ThisWorkbook
Set otherWorkbook = Workbooks.Open("C:\Users\HarrisQ\Desktop\My Test Folder\Test.xlsx")
Set targetSheet = otherWorkbook.Sheets("TargetSheet")
Set SampleS = mnv.Worksheets("Sheet1")
Dim worksheetNames()
Dim numRandRows()
worksheetNames = SampleS.Range("$D$1:$D$3").Value
numRandRows = SampleS.Range("$S$1:$S$3").Value
Dim copyRange As Range
Dim currSheetIndex As Long
Dim currSheet As Worksheet
Dim selectedRows As Range
For currSheetIndex = LBound(worksheetNames, 1) To UBound(worksheetNames, 1)
If WorksheetExists(CStr(worksheetNames(currSheetIndex, 1))) Then
Set currSheet = mnv.Worksheets(worksheetNames(currSheetIndex, 1))
With currSheet
Dim firstRow As Long
Dim lastRow As Long
Dim numRows As Long
firstRow = GetFirstLastRow(currSheet, 1)(0) 'I am using Column A (1) to specify column to use to find first and last row.
lastRow = GetFirstLastRow(currSheet, 1)(1)
numRows = numRandRows(currSheetIndex, 1)
Set selectedRows = RandRows(currSheet, firstRow, lastRow, numRows) 'Union cannot span different worksheets so copy paste at this point
Dim nextTargetRow As Long
If IsEmpty(targetSheet.Range("A1")) Then
nextTargetRow = 1
Else
nextTargetRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
End If
selectedRows.Copy targetSheet.Cells(nextTargetRow, 1)
Set selectedRows = Nothing
End With
End If
Next currSheetIndex
Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)
'MsgBox Durat & " seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function RandRows(ByRef currSheet As Worksheet, ByVal firstRow As Long, ByVal lastRow As Long, ByVal numRows As Long) As Range
'http://www.ozgrid.com/VBA/RandomNumbers.htm
Dim iArr As Variant
Dim selectedRows As Range
Dim i As Long
Dim r As Long
Dim temp As Long
Application.Volatile
ReDim iArr(firstRow To lastRow)
For i = firstRow To lastRow
iArr(i) = i
Next i
For i = lastRow To firstRow + 1 Step -1
r = Int(Rnd() * (i - firstRow + 1)) + firstRow
temp = iArr(r)
iArr(r) = iArr(i)
iArr(i) = temp
Next i
Dim currRow As Range
For i = firstRow To firstRow + numRows - 1
Set currRow = currSheet.Cells.Rows(iArr(i))
If Not selectedRows Is Nothing Then
Set selectedRows = Application.Union(selectedRows, currRow)
Else
Set selectedRows = currRow
End If
Next i
If Not selectedRows Is Nothing Then
Set RandRows = selectedRows
Else
MsgBox "No rows were selected for copying"
End If
End Function
Private Function GetFirstLastRow(ByRef currSheet As Worksheet, ByVal colNum As Long) As Variant
'colNum determine which column you will use to find last row
Dim startRow As Long
Dim endRow As Long
endRow = currSheet.Cells(currSheet.Rows.Count, colNum).End(xlUp).Row
startRow = FirstUsedCell(currSheet, colNum)
GetFirstLastRow = Array(startRow, endRow)
End Function
Private Function FirstUsedCell(ByRef currSheet As Worksheet, ByVal colNum As Long) As Long
'Finds the first non-blank cell in a worksheet.
'https://www.excelcampus.com/library/find-the-first-used-cell-vba-macro/
Dim rFound As Range
On Error Resume Next
Set rFound = currSheet.Cells.Find(What:="*", _
After:=currSheet.Cells(currSheet.Rows.Count, colNum), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFound Is Nothing Then
MsgBox currSheet & ":All cells are blank."
End
Else
FirstUsedCell = rFound.Row
End If
End Function
Function WorksheetExists(sName As String) As Boolean
'#Rory https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
Since QHarr's code needed to have all worksheet names should exist in the workbook did not work for me in the end. But with merging it some other project's function i made it work.
Opens an output xlsx file in same folder,
Index&Match to find the random rows amount
loop through all sheets with random function
then paste all randomized rows into Sheet named RASSAL
It may be unefficient since I really dont have much info on codes, but guess i managed to modify it into my needs.
Open to suggestions anyway and thanks to #QHarr very much for His/Her replies.
Sub RASSALFNL()
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Dim Durat As Long
startTime = Now()
Dim Sht As Worksheet
Dim mvn As Workbook
Dim FPath As String
Dim newWB As Workbook
Dim SheetN As Long
Dim i As Long
Dim lookupvalue As Long
Dim indexrange As Range
Dim matchrange As Range
Dim ranrows As Long
Dim firstRow As Long
Dim lastRow As Long
Dim numRows As Long
Dim sayf As String
Dim nextTargetRow As Long
Dim Rassal As Worksheet
Dim rngToCopy As Range
Dim sampleCount As Long
Dim ar() As Long
Dim total As Long
Dim rowhc As Long
FPath = ThisWorkbook.Path
Set mvn = Workbooks.Open(FileName:=ActiveWorkbook.Path & "\" &
Sheets("Data").Range("C2").Value & " " & Sheets("Data").Range("C3").Value
& " Muavinbol" & ".xlsx")
SheetN = mvn.Worksheets.count
Set SampleS = mvn.Sheets("Sheet1")
Set Rassal = Worksheets.Add
Rassal.Name = "RASSAL"
Set indexrange = SampleS.Range("$S$8:$S$304")
Set matchrange = SampleS.Range("$D$8:$D$304")
mvn.Activate
For Each Sht In mvn.Worksheets
Sht.Activate
If Sht.Name = "Sheet1" Or Sht.Name = "Sayfa1" Or Sht.Name = "RASSAL"
Then
'do nothing
Else
lookupvalue = Sht.Cells(1, 1).Value
ranrows = Application.WorksheetFunction.Index(indexrange,
Application.WorksheetFunction.Match(lookupvalue, matchrange, 0))
With Sht
firstRow = GetFirstLastRow(Sht, 1)(0)
lastRow = GetFirstLastRow(Sht, 1)(1)
numRows = ranrows
sayf = Sht.Name
'MsgBox sayf & " " & firstRow & " " & lastRow & " " &
ranrows
If numRows = 0 Then
'do nothing
Else
ar = UniqueRandom(numRows, firstRow, lastRow)
Set rngToCopy = .Rows(ar(0))
For i = 1 To UBound(ar)
Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
Next
If IsEmpty(mvn.Sheets("RASSAL").Range("A1")) Then
nextTargetRow = 1
Else
nextTargetRow =
mvn.Sheets("RASSAL").Cells(mvn.Sheets("RASSAL").Rows.count,
"A").End(xlUp).Row + 1
End If
rngToCopy.Copy Rassal.Cells(nextTargetRow, 1)
Set rngToCopy = Nothing
End If
End With
End If
Next Sht
rowhc = Rassal.Cells(Rows.count, 1).End(xlUp).Row
Durat = Round((Now() - startTime) * 24 * 60 * 60, 0)
MsgBox rowhc & " " & "random selections made in" & " " & Durat & "
seconds."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function GetFirstLastRow(ByRef Sht As Worksheet, ByVal colNum As
Long) As Variant
'colNum determine which column you will use to find last row
Dim firstRow As Long
Dim lastRow As Long
lastRow = Sht.Cells(Sht.Rows.count, colNum).End(xlUp).Row
firstRow = FirstUsedCell(Sht, colNum)
GetFirstLastRow = Array(firstRow, lastRow)
End Function
Private Function FirstUsedCell(ByRef Sht As Worksheet, ByVal colNum As
Long) As Long
Dim rFound As Range
On Error Resume Next
Set rFound = Sht.Cells.Find(What:="*", _
After:=Sht.Cells(Sht.Rows.count,
colNum), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFound Is Nothing Then
'do Nothing MsgBox Sh & ":All cells are blank."
End
Else
FirstUsedCell = rFound.Row
End If
End Function
Function UniqueRandom(ByVal numRows As Long, ByVal a As Long, ByVal b As
Long) As Long()
Dim i As Long, j As Long, x As Long
ReDim arr(b - a) As Long
Randomize
For i = 0 To b - a: arr(i) = a + i: Next
If b - a < count Then UniqueRandom = arr: Exit Function
For i = 0 To b - a 'Now we shuffle the array
j = Int(Rnd * (b - a))
x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
' After shuffling the array, we can simply take the first portion
If numRows = 0 Then
ReDim Preserve arr(0)
Else
ReDim Preserve arr(0 To numRows - 1)
On Error Resume Next
End If
'sorting, probably not necessary
For i = 0 To count - 1
For j = i To count - 1
If arr(j) < arr(i) Then x = arr(i): arr(i) = arr(j): arr(j) = x '
swap
Next
Next
UniqueRandom = arr
End Function
I need a macro to split my data from one Excel file to few others. It looks like this:
UserList.xls
User Role Location
DDAVIS XX WW
DDAVIS XS WW
GROBERT XW WP
SJOBS XX AA
SJOBS XS AA
SJOBS XW AA
I need, to copy data like this:
WW_DDAVIS.xls
User Role
DDAVIS XX
DDAVIS XS
WP_GROBERT.xls
User Role
GROBERT XW
AA_SJOBS.xls
User Role
SJOBS XX
SJOBS XS
SJOBS XW
I need every user, to have his own file. The problem appeared when I was told that the files need to be filled using template (template.xls). Looks the same, but data in the source file starts in cell A2, and in the template file from cell A8.
To copy data without template I used this code:
Public Sub SplitToFiles()
' MACRO SplitToFiles
' Last update: 2012-03-04
' Author: mtone
' Version 1.1
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.
Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created
iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow
Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path
If Dir(sFilePath + "\Split", vbDirectory) = "" Then
MkDir sFilePath + "\Split"
End If
'Turn Off Screen Updating Events
Application.EnableEvents = False
Application.ScreenUpdating = False
Do
' Get cell at cursor
Set rCell = osh.Cells(iRow, iCol)
sCell = Replace(rCell.Text, " ", "")
If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
' Skip condition met
Else
' Found new section
If iStartRow = 0 Then
' StartRow delimiter not set, meaning beginning a new section
sSectionName = rCell.Text
iStartRow = iRow
Else
' StartRow delimiter set, meaning we reached the end of a section
iStopRow = iRow - 1
' Pass variables to a separate sub to create and save the new worksheet
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1
' Reset section delimiters
iStartRow = 0
iStopRow = 0
' Ready to continue loop
iRow = iRow - 1
End If
End If
' Continue until last row is reached
If iRow < iTotalRows Then
iRow = iRow + 1
Else
' Finished. Save the last section
iStopRow = iRow
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1
' Exit
Exit Do
End If
Loop
'Turn On Screen Updating Events
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox Str(iCount) + " documents saved in " + sFilePath
End Sub
Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)
Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete
End Sub
Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
Dim ash As Worksheet ' Copied sheet
Dim awb As Workbook ' New workbook
' Copy book
osh.Copy
Set ash = Application.ActiveSheet
' Delete Rows after section
If iTotalRows > iStopRow Then
DeleteRows ash, iStopRow + 1, iTotalRows
End If
' Delete Rows before section
If iStartRow > iFirstRow Then
DeleteRows ash, iFirstRow, iStartRow - 1
End If
' Select left-topmost cell
ash.Cells(1, 1).Select
' Clean up a few characters to prevent invalid filename
sSectionName = Replace(sSectionName, "/", " ")
sSectionName = Replace(sSectionName, "\", " ")
sSectionName = Replace(sSectionName, ":", " ")
sSectionName = Replace(sSectionName, "=", " ")
sSectionName = Replace(sSectionName, "*", " ")
sSectionName = Replace(sSectionName, ".", " ")
sSectionName = Replace(sSectionName, "?", " ")
' Save in same format as original workbook
ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat
' Close
Set awb = ash.Parent
awb.Close SaveChanges:=False
End Sub
The problem in this one, is that I have no idea how to make name not DDAVIS.xls, but using WW_DDAVIS.xls (location_user.xls). Second problem - Use template. This code just copies whole workbook and erases all wrong data. All I need, is to copy value of the right data to this template.
Unfortunately I didn't find working code and I'm not so fluent in VBA to make it alone.
I tried other one, that worked only in half. It copied the template to every file and name it properly, but I couldn't figure out how to copy cells to the right files.
Option Explicit
Sub copyTemplate()
Dim lRow, x As Integer
Dim wbName As String
Dim fso As Variant
Dim dic As Variant
Dim colA As String
Dim colB As String
Dim colSep As String
Dim copyFile As String
Dim copyTo As String
Set dic = CreateObject("Scripting.Dictionary") 'dictionary to ensure that duplicates are not created
Set fso = CreateObject("Scripting.FileSystemObject") 'file scripting object for fiile system manipulation
colSep = "_" 'separater between values of col A and col B for file name
dic.Add colSep, vbNullString ' ensuring that we never create a file when both columns are blank in between
'get last used row in col A
lRow = Range("A" & Rows.Count).End(xlUp).Row
x = 1
copyFile = "c:\location\Template.xls" 'template file to copy
copyTo = "C:\location\List\" 'location where copied files need to be copied
Do
x = x + 1
colA = Range("G" & x).Value 'col a value
colB = Range("A" & x).Value ' col b value
wbName = colA & colSep & colB ' create new file name
If (Not dic.Exists(wbName)) Then 'ensure that we have not created this file name before
fso.copyFile copyFile, copyTo & wbName & ".xls" 'copy the file
dic.Add wbName, vbNullString 'add to dictionary that we have created this file
End If
Loop Until x = lRow
Set dic = Nothing ' clean up
Set fso = Nothing ' clean up
End Sub
sub test()
dim wb
dim temp
dim rloc
rloc= "result files location"
set wb =thisworkbook
set temp= workbook.open(template path)
' getting last row
lrow=wb.sheets(1).range("A1:A"&rows.count).end(xlup).row
icounter=0
for i=2 to lrow 'leaving out the header row
with wb.sheets(1)
if cells(i,1).value=cells(i,1).offset(1,1).value then
icounter=icounter+1
else
if icounter>0 then
range(cells(i,1):(cells(i,1).offset(-icounter,2)).copy
wb.sheet(8,1).pastespecial xlvalues
application.cutcopymode=false
filename=str(cells(i,1).value) & "_" & str(cells(i,3).value) & "".xls"
chdir rloc
temp.saveas(filename,xlworkbookdefault)
else
range(cells(i,1):cells(i,2)).copy
wb.sheets(8,1).pastespecial xlvalues
application.cutcopymode=false
filename=str(cells(i,1).value) & "_" & str(cells(i,3).value) & ".xls"
chdir rloc
temp.saveas(filename,xlworkbookdefault)
end if
end if
end with
next i
wb.close savechanges:=false
temp.close savechanges:=false
end sub
this might work. i haven't tested the code. its a bit crude. i am also just a beginner in vba. forgive me if it contains errors.
look at the logic. if its all you want create a code from scratch yourself.
#Sivaprasath V
Thanks, looks like it should work. I've changed it a little bit, to look better and to fix some issues
Sub test()
Dim wb
Dim temp
Dim rloc
rloc = "C:\LOCATION\result\"
Set wb = ThisWorkbook
Set temp = Workbooks.Open("C:\LOCATION\Template.xls")
' getting last row
lRow = wb.Sheets(1).Range("A1:A" & Rows.Count).End(xlDown).Row 'changed xlUp for xlDown
icounter = 0
For i = 2 To lRow 'leaving out the header row
With wb.Sheets(1)
Range("C2").Value = Cells(i, 1).Value
If Cells(i, 1).Value = Cells(i, 1).Offset(1, 0).Value Then 'changed offset from (1,1)
icounter = icounter + 1
Else
If icounter > 0 Then
Range(cells(i,1):(cells(i,1).offset(-icounter,7)).Copy 'error
wb.Sheet(8, 1).PasteSpecial xlValues
Application.CutCopyMode = False
Filename = Str(Cells(i, 1).Value) & "_" & Str(Cells(i, 3).Value) & ".xls"
ChDir rloc
temp.SaveAs Filename, xlWorkbookDefault
Else
Range(cells(i,1):cells(i,7)).Copy 'error
wb.Sheets(8, 1).PasteSpecial xlValues
Application.CutCopyMode = False
Filename = Str(Cells(i, 1).Value) & "_" & Str(Cells(i, 3).Value) & ".xls"
ChDir rloc
temp.SaveAs Filename, xlWorkbookDefault
End If
End If
End With
Next i
wb.Close savechanges:=False
temp.Close savechanges:=False
End Sub
I'm fighting with an error that i can't quite understand. In line:
Range(cells(i,1):(cells(i,1).offset(-icounter,7)).Copy
and this:
Range(cells(i,1):cells(i,7)).Copy
There is an error saying:
Compile error:
Expected: list separator or )
Can't figure out how to fix it. Code looks good for me.
#EDIT
Went around the error using new variable ("C" & i & ":" & "F" & i - icounter)
after some minor changes it worked, thanks :)
The below is my code. I have tried many different solutions but none seem to work. Any help would be appreciated.
Sub MultiDimensiionArray1()
'array for sheet one and sheet two
Dim myArraySheet1(0 To 3, 0 To 4) As Variant
Dim myArraySheet2(0 To 5, 0 To 4) As Variant
Dim i As Long, j As Long ' dimension counter for for sheet one
Dim Dimension1 As Long, Dimension2 As Long ' dimension counter for for sheet one
'number of rows in sheet one
Dim x As Integer, NumRows As Integer
Sheet1.Activate
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
'store everything on sheet one in array
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
myArraySheet1(i, j) = Range("A2").Offset(i, j).Value
Next j
Next i
'store everything on sheet two in array
Sheet2.Activate
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
myArraySheet2(Dimension1, Dimension2) = Range("A2").Offset(Dimension1, Dimension2).Value
Next Dimension2
Next Dimension1
'READ FROM ARRAY/OR DISPLAY THE RESULT
Sheet1.Activate
' Select sheet one cell G2
Range("G2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
'if sheet one row equal to sheet two row execute the below code
If myArraySheet1(i, j) = myArraySheet2(Dimension1, Dimension2) Then
ActiveCell.Value = "YES IT IS DUPE AND NOT RESOLVED"
ActiveCell.Interior.ColorIndex = 4
ActiveCell.Font.ColorIndex = 2
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Value = "Brand New"
ActiveCell.Interior.ColorIndex = 3
ActiveCell.Font.ColorIndex = 2
End If
Next Dimension2
Next Dimension1
Next j
Next i
Next
End Sub
I did not use array but the code below give you the expected output that you want:
Option Explicit
Sub Compare()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Lastrow As Long, Lastrow2 As Long
Dim i As Integer, j As Integer, c As Integer
Dim FOUND As Boolean
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
Lastrow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
i = 2
Do
FOUND = False
For j = 2 To Lastrow2
For c = 1 To 5
If ws1.Cells(i, c).Value = ws2.Cells(j, c).Value Then
FOUND = True
Else
FOUND = False
Exit For
End If
Next c
If FOUND = True Then
ws1.Cells(i, 7) = "YES IT IS DUPE AND NOT RESOLVED"
Exit For
End If
Next j
If FOUND = False Then
ws1.Cells(i, 7) = "Brand new"
End If
i = i + 1
Loop While i < Lastrow + 1
End Sub
With this you'll have two arrays containing values of cells that aren't equal so you'll be able to use the values you need to do what you want
Sub Test()
Dim DiffSh1() As Variant
Dim DiffSh2() As Variant
Call Compare_Sheets(ThisWorkbook.Sheets("Sheet1"), ThisWorkbook.Sheets("Sheet2"), DiffSh1, DiffSh2)
'Now you can use the values in the two arrays as you need
For x = LBound(DiffSh1, 1) To UBound(DiffSh1, 1)
For y = LBound(DiffSh1, 2) To UBound(DiffSh1, 2)
If DiffSh1(x, y) <> "" Then
MsgBox ("Cell at Row " & x & " Column " & y & " isn't equal:" & vbCrLf & _
"Value in sheet1 is: " & DiffSh1(x, y) & vbCrLf & _
"Value in sheet2 is: " & DiffSh2(x, y))
End If
Next y
Next x
End Sub
Public Sub Compare_Sheets(ByVal Sh1 As Worksheet, ByVal Sh2 As Worksheet, ByRef DiffIn1() As Variant, ByRef DiffIn2() As Variant)
Dim LastCol
Dim LastRow
LastCol = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Column
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column > LastCol Then
LastCol = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column
End If
LastRow = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Row
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row > LastRow Then
LastRow = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row
End If
ReDim DiffIn1(1 To LastRow, 1 To LastCol)
ReDim DiffIn2(1 To LastRow, 1 To LastCol)
Dim mCol As Long, mRow As Long
For mCol = 1 To LastCol
For mRow = 1 To LastRow
If Sh1.Cells(mRow, mCol) <> Sh2.Cells(mRow, mCol) Then
DiffIn1(mRow, mCol) = Sh1.Cells(mRow, mCol).Value
DiffIn2(mRow, mCol) = Sh2.Cells(mRow, mCol).Value
Else
DiffIn1(mRow, mCol) = ""
DiffIn2(mRow, mCol) = ""
End If
Next mRow
Next mCol
End Sub