Guys I'm stuck with my code(the array part if not working).I would appreciate a help.
I have 6 worksheets(JAN,FEB,MAR,APR,MAY,JUN and Reports).JAN-JUN worksheets contain employees absences records.
I need to transfer the records from worksheets JAN-JUN(employees name are not in proper order) paste in master worksheets called "Report"(all name are in ascending order)
In report I have the following header(JAN ,FEB ,MAR .......JUN ) in cells B1,C1,D1,E1,F1,G1.
Range("I") in each worksheets contains total absences by employees for a given month.
Range("H") in each worksheets contain employees who absent for the month.
I need to transfer only Range("I") from each worksheet and paste based on the the relevant months and employees.
My code contains an array of cell B1 to G1 from master worksheets.
Sub transferABS1()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
Dim arRng() As Variant
Dim iRw As Integer
Dim iCol As Integer
arRng = Sheets("Reports").Range("B1:G1")
For iRw = 1 To UBound(arRng, 1)
For iCol = 1 To UBound(arRng, 2)
lastrow1 = Sheets(arRng).Range("H" & Rows.Count).End(xlUp).Row
For i = 1 To lastrow1
myname = Sheets(arRng).Cells(i, "H").Value
Sheets("Reports").Activate
lastrow2 = Sheets("Reports").Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To lastrow2
If Sheets("Reports").Cells(j, "A").Value = myname Then
Sheets(arRng).Activate
Sheets(arRng).Range(Cells(i, "I")).Copy
Sheets("Reports").Activate
ActiveSheet.Cells(j, iCol).Select
ActiveSheet.Paste
End If
Next j
Application.CutCopyMode = False
Next i
Next iCol
Next iRw
End Sub
It would probably be much easier if you just created a starter table that had headers of Name/Month/Hours. From there you could run a pivot table, or variety of analysis.
To get in a table format is easier than your two dimensional Name by Month format. This code will list all values on your Report sheet.
Sub listAllNamesMonthsAndAmounts()
Const theMonths As String = "Jan,Feb,Mar,Apr,May,Jun,Jul,"
Dim ws As Worksheet, i As Long, g As Long, aCell As Range
g = 1
ReDim eList(1 To 3, 1 To g) As Variant
For Each ws In ThisWorkbook.Worksheets
If InStr(1, theMonths, ws.Name & ",", vbTextCompare) > 0 Then
For Each aCell In Intersect(ws.Range("H:H"), ws.UsedRange)
If aCell <> "" Then
ReDim Preserve eList(1 To 3, 1 To g)
eList(1, g) = ws.Name
eList(2, g) = aCell.Value
eList(3, g) = aCell.Offset(0, 1).Value
g = g + 1
End If
Next aCell
End If
Next ws
Sheets("Report").Range("A2").Resize(UBound(eList, 2), UBound(eList)).Value = Application.WorksheetFunction.Transpose(eList)
End Sub
Related
I am trying to make VBA to copy data and paste to matching worksheet name.
"Setting" Worksheet will have all mixed data of item types.
With VBA, copy & paste values on A & D columns to matching worksheet name.
VBA code will go through entire A7 -> lastrow
worksheet name is based on the item types.
Right now, I am stuck on this part - setting supplier as dynamic worksheet
Below is the issue area: "out of range"
For i = 7 To lastrow1
'setting spl as the value of the item type
spl = Cells(i, "A").Value
'setting supplier as the worksheet name
Set supplier = Sheets(spl)
Below is the entire VBA code:
I have found an existing code, and had been tweaking to fit my usage.
Sub Copy_Data()
Dim lastrow1 As Long, i As Long, auxRow As Long, offsetRow As Long
Dim spl As String
Dim supplier As Worksheet
Set ws = Sheets("SETTING")
lastrow1 = ws.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For i = 7 To lastrow1
'setting spl as the value of the item type
spl = Cells(i, "A").Value
'setting supplier as the worksheet name
Set supplier = Sheets(spl)
auxRow = supplier.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
If auxRow > 1 Then auxRow = auxRow + 1
If auxRow = 1 Then auxRow = offsetRow
supplier.Cells(auxRow, "A") = ws.Cells(i, "A")
supplier.Cells(auxRow, "B") = ws.Cells(i, "D")
Next i
End Sub
Thank you all in an advance.
I have tried to define the worksheet to have dynamic value - based on item type on column A.
But keep receiving 'out of range' when setting the worksheet.
"out of range" because you are opening one sheet from the list. you need to open setting sheet when you run this code.
Another thing don't use Find function
ws.Columns("A").Find("*", searchorder:=xlByRows, earchdirection:=xlPrevious).Row
because returns either of the following outcomes:
If a match is found, the function returns the first cell where the value is located.
If a match is not found, the function returns nothing.
That's will give you error because you define lastrow1 and auxRow as long
instead use this
lastrow1 = ws.Range("A" & Rows.Count).End(xlUp).Row
Try to use this code
Sub Copy_Data()
Dim lastrow1 As Long, i As Long, auxRow As Long, offsetRow As Long
Dim spl As String
Dim supplier As Worksheet
Dim ws As Worksheet
Set ws = Sheets("SETTING")
lastrow1 = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 7 To lastrow1
'setting spl as the value of the item type
spl = Cells(i, "A").Value
'setting supplier as the worksheet name
Set supplier = Sheets(spl)
auxRow = supplier.Range("A" & Rows.Count).End(xlUp).Row + 1
supplier.Cells(auxRow, "A") = ws.Cells(i, "A")
supplier.Cells(auxRow, "B") = ws.Cells(i, "D")
Next i
End Sub
Please, test the next code. If follows the scenario I tried describing in my above comment: place the range to be processed in an array, iterate it and place the necessary data in the dictionary, then drop the processed result in each appropriate sheet. Working only in memory, until dropping the processed result makes it very fast, even for large data:
Sub distributeIssues()
Dim shS As Worksheet, lastR As Long, wb As Workbook, arr, arrIt, arrFin, i As Long
Dim key, dict As Object
Set wb = ThisWorkbooks
Set shS = wb.Sheets("SETTING")
lastR = shS.Range("A" & shS.rows.count).End(xlUp).row 'last row
arr = shS.Range("A7:D" & lastR).Value2 'place the range in an array for faster iteration/processing
'place the range to be processed in dictionary:
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr) 'iterate between the array rows
If Not dict.Exists(arr(i, 1)) Then 'if key does not exist
dict.Add arr(i, 1), Array(arr(i, 4)) 'create it and place the value in D:D as array item
Else
arrIt = dict(arr(i, 1)) 'place the item content in an array
ReDim Preserve arrIt(UBound(arrIt) + 1) 'extend the array with an element
arrIt(UBound(arrIt)) = arr(i, 4) 'place value from D:D in the last element
dict(arr(i, 1)) = arrIt 'place back the array as dictionary item
End If
Next i
'Stop
'drop the necessary value in the appropriate sheet:
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For Each key In dict
With wb.Worksheets(key).Range("B9").Resize(UBound(dict(key)) + 1, 1)
.Value = Application.Transpose(dict(key))
.Offset(, -1).Value = key
End With
Next key
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "Ready..."
End Sub
Please, send some feedback after testing it.
If something not clear enough, do not hesitate to ask for clarifications.
The items can be in any order. No necessary to be sorted...
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 2 years ago.
Improve this question
Can someone suggest me on how to appending into a master sheet by row after row by taking the first row of each sheet from multiple sheets then move on to second rows appending, suppose in the first iteration, we have each first row of each sheet, that should copy and paste as row1, row2, row3 into the master sheet, then in the next iteration the second row of each sheet comes and add/append at the end of the master sheet means it would be row4, row5...etc into the master sheet
I even tried below piece of code which sent from the user https://stackoverflow.com/users/7444507/michael
but I can't able to get the right output
Public Sub MergeTabs()
'Merges selected tabs (or all visible tabs if only 1 selected) in current workbook into a new tab
Dim i As Integer, wb As Workbook, w As Window, wsTo As Worksheet, wsFrom As Collection 'Worksheet collection
Dim strScope As String, strNewTab As String
Dim raTarget As Range
Set wb = ActiveWorkbook
Set w = ActiveWindow
Set wsFrom = New Collection
If w.SelectedSheets.Count = 1 Then
For i = 1 To wb.Worksheets.Count
If wb.Worksheets(i).Visible Then wsFrom.Add wb.Worksheets(i)
Next
strScope = "ALL VISIBLE"
Else
For i = 1 To w.SelectedSheets.Count
If w.SelectedSheets(i).Visible Then wsFrom.Add w.SelectedSheets(i)
Next
strScope = wsFrom.Count & " SELECTED"
End If
strNewTab = InputBox("Merge data from " & strScope & " sheets to new sheet named:", "Merge tabs", "All")
If strNewTab = vbNullString Then Exit Sub
Set wsTo = wb.Worksheets.Add(wsFrom(1), Count:=1) 'Add before first selected sheet
wsTo.Name = strNewTab
wsFrom(1).Range("A1").CurrentRegion.Copy
wsTo.Range("A1").PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
For i = 2 To wsFrom.Count
wsFrom(i).Range("A2", wsFrom(i).Range("A1").CurrentRegion.Cells(wsFrom(i).Range("A1").CurrentRegion.Cells.Count)).Copy
wsTo.Cells(wsTo.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
Next i
wsTo.Range("A1").Select
MsgBox "Merge Done"
End Sub
Try this code, please. It firstly counts the maximum number of rows for sheets to be processed, the maximum number of columns and number of sheets. For maximum number of columns, it counts only the sheet first row. So, it must be the longer of the sheet! All that is done for being able to correctly dimension the arrFin array which will collect all the lines. It will have more rows then necessary, multiplying the max number of rows with the sheets number. Then the array is filled with data. I switched the rows with columns because only the second dimension of the array can be Redim, preserving the existing data. Finally the transposed array is dropped in the Master sheet at once. It should work very fast... Please, confirm that it works as you need.
Private Sub testApendCopySameRows()
Dim ws As Worksheet, wDest As Worksheet, arrWork As Variant, arrFin As Variant
Dim lastCol As Long, lastC As Long, lastColM As Long, lastR As Long, nrSheets As Long
Dim maxR As Long, maxRows As Long, i As Long, j As Long, k As Long
Set wDest = Worksheets("Master1") ' please, use here your master sheet name
For Each ws In Worksheets
If ws.Name <> wDest.Name Then
'If ws.Name = "sh1" Or ws.Name = "sh2" Then 'used (by me) for testing
nrSheets = nrSheets + 1
lastC = ws.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
If lastC > lastCol Then lastCol = lastC
maxR = ws.Range("A" & Cells.Rows.Count).End(xlUp).Row
If maxR > maxRows Then maxRows = maxR
'End If
End If
Next
ReDim arrFin(1 To lastCol, 1 To maxRows * nrSheets)
ReDim arrWork(1 To 1, 1 To lastCol)
k = 1 'arrFin first row
For i = 1 To maxRows
For Each ws In Worksheets
If ws.Name <> wDest.Name Then
'If ws.Name = "sh1" Or ws.Name = "sh2" Then
lastR = ws.Range("A" & Cells.Rows.Count).End(xlUp).Row
If i <= lastR Then
'input the same rows content in the array:
arrWork = ws.Range(ws.Cells(i, 1), ws.Cells(i, lastCol)).value
For j = 1 To lastCol
arrFin(j, k) = arrWork(1, j)
Next j
k = k + 1
Erase arrWork
ReDim arrWork(1 To 1, 1 To lastCol)
End If
'End If
End If
Next
Next i
ReDim Preserve arrFin(1 To lastCol, 1 To k - 1)
wDest.Range("A1").Resize(UBound(arrFin, 2), UBound(arrFin, 1)).value = _
WorksheetFunction.Transpose(arrFin)
End Sub
Do not forget to use your Master sheet name in Set wDest = Worksheets("Master1")!
All-
I'm very new to VBA and I really need help. I have a worksheet called Sheet 1 that looks like this (This is where the data will be copied from)
and another sheet (Sheet2) that looks like this (this is where the data will be copied to). Notice that the order is not the same as above
When a user types in a place such as "Paris" I want it to copy all corresponding values with "Paris" and it's associated rows. So the end result should look like this
Here is the code I have so far. Right now I can pull all the corresponding values based on the Users input, but I cannot for the life of me figure out how to get the associated rows. Please help! Any input will be highly appreciated.
Dim x As String
Dim K As Long
Dim ct As Variant
Dim r As Range
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
x = Application.InputBox("Please Enter Place")
w1.Activate
K = 3
For Each r In Intersect(Range("C3:C3" & a), ActiveSheet.UsedRange)
ct = r.Value
If InStr(ct, x) > 0 And ct <> "" Then
r.Copy w2.Cells(K, 1)
K = K + 1
w2.Activate
End If
Next r
End Sub
Assign the entire range to an array for quicker looping, then once the array finds a match to your inputstring, rewrite the values to your 2nd sheet.
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, wsArr()
set ws1 = thisworkbook.worksheets("Sheet1")
set ws2 = thisworkbook.worksheets("Sheet2")
With ws1
wsArr = .Range(.Cells(3, 1), .Cells(LastRow(ws1), 4)).Value
End With
Dim findStr As String
findStr = InputBox("Please Enter Place")
Dim i As Long, r as long
Application.ScreenUpdating = False
With ws2
.Range("A3:D3").Value = array("Place", "Name", "Thing", "Animal")
For i = LBound(wsArr) To UBound(wsArr)
If wsArr(i, 3) = findStr Then
r = LastRow(ws2) + 1
.Cells(r, 1) = wsArr(i, 3)
.Cells(r, 2) = wsArr(i, 1)
.Cells(r, 3) = wsArr(i, 2)
.Cells(r, 4) = wsArr(i, 4)
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function LastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1) As Long
With ws
LastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
End Function
For even better performance, consider doing a COUNTIF() to get the count of the number of findStr occurances in your range - that way you can use this value to ReDim a new array in order to write the matches there, then write the array to Sheet2 all at once.
I have 2 columns on a sheet "list", one column that lists all business entities, the other lists all org units. The functionality of the code below works perfectly but returns an error because it exceeds the sheet row limit.
The data is pasted onto a sheet "cc_act" is there a way to at point of error create a new sheet called "cc_act1"...."cc_act2" until the script is complete?
Declare Function HypMenuVRefresh Lib "HsAddin" () As Long
Sub cc()
Application.ScreenUpdating = False
Dim list As Worksheet: Set list = ThisWorkbook.Worksheets("list")
Dim p As Worksheet: Set p = ThisWorkbook.Worksheets("p")
Dim calc As Worksheet: Set calc = ThisWorkbook.Worksheets("calc")
Dim cc As Worksheet: Set cc = ThisWorkbook.Worksheets("cc_act")
Dim cc_lr As Long
Dim calc_lr As Long: calc_lr = calc.Cells(Rows.Count, "A").End(xlUp).Row
Dim calc_lc As Long: calc_lc = calc.Cells(1,
calc.Columns.Count).End(xlToLeft).Column
Dim calc_rg As Range
Dim ctry_rg As Range
Dim i As Integer
Dim x As Integer
list.Activate
For x = 2 To Range("B" & Rows.Count).End(xlUp).Row
If list.Range("B" & x).Value <> "" Then
p.Cells(17, 3) = list.Range("B" & x).Value
End If
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If list.Range("A" & i).Value <> "" Then
p.Cells(17, 4) = list.Range("A" & i).Value
p.Calculate
End If
p.Activate
Call HypMenuVRefresh
p.Calculate
'''changes country on calc table
calc.Cells(2, 2) = p.Cells(17, 4)
calc.Cells(2, 3) = p.Cells(17, 3)
calc.Calculate
'''copy the calc range and past under last column
With calc
Set calc_rg = calc.Range("A2:F2" & calc_lr)
End With
With cc
cc_lr = cc.Cells(Rows.Count, "A").End(xlUp).Row + 1
calc_rg.Copy
cc.Cells(cc_lr, "A").PasteSpecial xlPasteValues
End With
Next i
Next x
Application.ScreenUpdating = True
End Sub
I suppose there are a few ways to handle something like this. See the code sample below, and adapt it to your specific needs.
Sub LongColumnToAFewColumns()
Dim wsF As Worksheet, WST As Worksheet
Dim rf As Range, rT As Range
Dim R As Long, j As Integer
' initialize
Set wsF = ActiveSheet
Set WST = Sheets.Add
WST.Name = "Results"
j = 1
For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step 65536
wsF.Cells(R, 1).Resize(65536).Copy
WST.Cells(j, 1).PasteSpecial xlPasteValues
WST.Cells(j, 1).PasteSpecial xlPasteValues
j = j + 1
Next R
End Sub
As an aside, you may want to consider using MS Access for this kind of thing. Or, better yet, Python or even R. Good luck with your project.
I've spent the majority of my afternoon looking for a way to return a text value in a cell based on two columns. I'm looking to match a values from Sheet1, columns A & F to sheet2, returning the value in column B where these two match into sheet 1.
To visualize:
Sheet 1 Sheet 2
A F A B F
x b x c y
x g x k b
Is there a way to use VLOOKUP to do this that I missed? I'm pretty confident that I'm missing something simple, but it's giving me a hard time.
Thanks in advance!
The following Subscript does exactly what you asked:
Sub DoThaThing()
Dim i As Long, lastRow1 As Long
Dim Sheet1A As Variant, Sheet1F As Variant, firstFound As String
Dim findData As Range
lastRow1 = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRow1 Step 1
Sheet1A = Sheets("Sheet1").Cells(i, "A").Value
Sheet1F = Sheets("Sheet1").Cells(i, "F").Value
Set findData = Sheets("Sheet2").Columns("A:A").Find(What:=Sheet1A, _
After:=Sheets("Sheet2").Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not findData Is Nothing Then
'First instance found, loop if needed
firstFound = findData.Address
Do
'Found, check Column F (5 columns over with offset)
If findData.Offset(0, 5).Value = Sheet1F Then
'A and F match get data from B (1 column over with offset)
Sheets("Sheet1").Cells(i, "B").Value = findData.Offset(0, 1).Value
Exit Do
Else
'F doesnt match, search next and recheck
Set findData = Sheets("Sheet2").Columns("A:A").FindNext(findData)
End If
Loop While Not findData Is Nothing And firstFound <> findData.Address
Else
'Value on Sheet 1 Column A was not found on Sheet 2 Column A
Sheets("Sheet1").Cells(i, "B").Value = "NOT FOUND"
End If
Next
End Sub
Edit: Infinite Loop Fixed.
try this code, it's work for me :
Option Explicit
Sub test()
' Active workbook
Dim wb As Workbook
Set wb = ThisWorkbook
Dim i As Long
Dim j As Long
'*******************************************
'Adapt this vars
'define your sheets
Dim ws_1 As Worksheet
Dim ws_2 As Worksheet
Set ws_1 = wb.Sheets("Feuil1") 'change name of the sheet to complete
Set ws_2 = wb.Sheets("Feuil2") 'change name of the sheet with all data
'definie the last Rows
Dim lastRow_ws1 As Long
Dim lastRow_ws2 As Long
lastRow_ws1 = ws_1.Range("A" & Rows.Count).End(xlUp).Row + 1 'if you need, adjust column to find last row
lastRow_ws2 = ws_2.Range("A" & Rows.Count).End(xlUp).Row + 1 'if you need, adjust column to find last row
'*******************************************
Dim keyMach1 As String
Dim keyMach2 As String
For j = 1 To lastRow_ws1
For i = 1 To lastRow_ws2
Dim keySearch As String
Dim keyFind As String
keySearch = ws_1.Cells(j, 1).Value & ws_1.Cells(j, 6).Value 'I concat both cell to create o key for the search
keyFind = ws_2.Cells(i, 1).Value & ws_1.Cells(i, 6).Value ' idem to match
If keySearch = keyFind Then
ws_1.Cells(j, 2).Value = ws_2.Cells(i, 2).Value
End If
Next i
Next j
End Sub