Can anybody help me edit? I want to copy from column to another workbook column using array.
The range inside the array is the Alphabet of the column i want to copy/paste.
Sub setting2()
Dim wb As ThisWorkbook
Dim here As Workbook
Dim there As Workbook
Dim source() As Variant
Dim log() As Variant
Dim LastRowHere() As Integer
Dim LastRowThere() As Integer
'Open both workbooks first:
Set here = Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting2.xlsm")
Set there =Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting3.xlsm")
Windows("Setting.xlsm").Activate
source() = Array(Sheets("Sheet1").Range("E11"), Range("E12"), Range("E13"), Range("E14"), Range("E15"), Range("E16"),Range("E17").Value)
Windows("Setting.xlsm").Activate
log() = Array(Sheets("Sheet1").Range("J11"), Range("J12"),Range("J13"),Range("J14"), Range("J15"), Range("J16"), Range("J17").Value)
Windows("Setting2.xlsm").Activate
LastRowHere() = Array(Sheets("Sheet1").Rows.Count, source().End(xlUp).Row)
Windows("Setting3.xlsm").Activate
LastRowThere() = Array(Sheets("Sheet1").Rows.Count, log()).End(xlUp).Row
For i = 1 To LastRowHere()
LastRowThere(1) = there.Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count.log(1)).End(xlUp).Row
For k = 1 To LastRowThere()
'here.Sheets("Sheet1").Cells(i, k).Copy Destination:=there.Sheets("Sheet1").Cells(i, k)
here.Sheets("Sheet1").Rows(i).Columns(source(1)).Copy Destination:=there.Sheets("Sheet1").Rows(k + 1).Columns(log(1))
Next k
Next i
End Sub
Your problem is source().End(xlUp).Row. You're trying to use it as a range - which it's not. That is giving you the error.
You'd be better to populate your array by using a loop. And, unless you really want to carry the cell formatting across to the destination sheet, better not to use Copy since then you don't have to activate the destination sheet.
Not sure if the code below exactly fits your need. I wasn't sure of the purpose of log() array so I've left it out. The below copies the values of a single column from Source sheet to Destination sheet.
'Open both workbooks first:
Set here = Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting2.xlsm")
Set there =Workbooks.Open("C:\Users\jesslynn\Desktop\macro\Setting3.xlsm")
SourceCol = 5 'Column E from your example
Set SourceSht = here.Sheets(1)
Set DestnSht = there.Sheets(1)
With SourceSht
'Get last cell in the column
LastRow = .Cells(.Rows.Count, SourceCol).End(xlUp).row
End With
With DestnSht
'Get last cell in the column
DestnLastRow = .Cells(.Rows.Count, SourceCol).End(xlUp).row
End With
'Loop through all cells (assumes row 1 is header)
For r = 2 to LastRow
'Assign value from Source to Destination sheet
i = i + 1
DestnSht.Cells(DestnLastRow + i, SourceCol) = SourceSht.Cells(r, SourceCol)
Next
Try this.
I assume you need copy the value from range E11 to E17 and J11 to J17
Option Explicit
Dim CurrentWorkbook As Workbook
Dim SourceWorkbook As Workbook
Dim DestWorkbook As Workbook
Dim CurrentWorksheet As Worksheet
Dim SourceWorksheet As Worksheet
Dim DestWorksheet As Worksheet
Sub setting2()
Dim SourceLastRow As Long
Dim DestLastRow As Long
Set CurrentWorkbook = ActiveWorkbook
Set CurrentWorksheet = CurrentWorkbook.ActiveSheet
Set SourceWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyData1.xlsx") 'change to your path
Set DestWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyTemplate.xlsx") 'change to your path
Set SourceWorksheet = SourceWorkbook.Sheets(1)
Set DestWorksheet = DestWorkbook.Sheets(1)
SourceLastRow = SourceWorksheet.Cells(Rows.Count, "E").End(xlUp).Row
DestLastRow = DestWorksheet.Cells(Rows.Count, "J").End(xlUp).Row + 1
SourceWorksheet.Range("E11:E17").Copy Destination:=DestWorksheet.Range("E" & DestLastRow + 1) 'Change to the column you want
SourceWorksheet.Range("J11:J17").Copy Destination:=DestWorksheet.Range("J" & DestLastRow + 1) 'Change to the column you want
End Sub
Related
the VBA code below scans two different datasets/tables in excel against possible matches in Worksheet 2 (aka SecondaryTable) and Worksheet 1 (aka MainTable). Both “Main” and “Secondary” Tables are Table Objects in Excel:
Sub looping()
Dim lRow As Long
Dim lCol As Long
Dim lRow2 As Long
Dim lCol2 As Long
Dim wordsArray() As Variant
wordsArray = Worksheets("SecondaryTable").Range("A2:A" & lRow2).Value
Dim word As Variant
Dim cell As Range
Set sht = Worksheets("MainTable")
Set sht2 = Worksheets("SecondaryTable")
lRow = sht.Range("A1").CurrentRegion.Rows.Count
lCol = sht.Range("A1").CurrentRegion.Columns.Count
lRow2 = sht2.Range("A1").CurrentRegion.Rows.Count
lCol2 = sht2.Range("A1").CurrentRegion.Columns.Count
For Each cell In Worksheets("MainTable").Range("I2:I" & lRow)
For Each word In wordsArray
If InStr(cell.Value, word) > 0 Then
cell.Offset(0, -2).Value = cell.Offset(0, -2).Value & " " & word
End If
Next word
Next cell
End Sub
I wanted to ask if there is any good way (after several failed attempts and errors via VBA in the last couple of days) of doing the following:
Is there any way of offsetting the value identified into a specific Table column instead of counting columns to determine exactly where the data will be populated / should be offset to? I tried replacing cell.Offset(0, -2).Value with a Table reference to the column name such as “Results” however I kept getting errors.
Would there any specific way after the code finds a match from wordsArray = Worksheets("SecondaryTable").Range("A2:A" & lRow2).Value to return a different value from an adjacent cell located in Range("B2:B" & lrow2).Value? The secondary table contains partial keywords in one column via which the loop is executed and a second adjacent column that contains the full name. I tried offsetting the variable word e.g., word.offset(0,1).Value in an effort to pull the name from Column 2 but only got errors.
Secondary Table example
Column A (keywords) Column B(full string)
Dog big dog
Cat small cat
Since you say Tables are Table Objects in Excel: utilise that fact. These are called ListObject's in VBA.
Replace the various NameOf... strings with your actual names
Sub looping()
Dim wordsArray() As Variant
Dim FullWordsArray() As Variant
Dim wb As Workbook
Dim sht As Worksheet
Dim sht2 As Worksheet
Dim loSecondary As ListObject
Dim loMain As ListObject
Set wb = ThisWorkbook ' or specify a workbook
Set sht = wb.Worksheets("MainTable")
Set sht2 = ws.Worksheets("SecondaryTable")
Set loMain = sht.ListObjects(1) ' or by name: Set loMain = sht.ListObjects("YourTableName')
Set loSecondary = sht2.ListObjects(1)
' get two arrays, one for lookup, and the other for replacements
wordsArray = loSecondary.ListColumns("NameOfWordColumn").DataBodyRange.Value2
FullWordsArray = loSecondary.ListColumns("NameOfFullWordColumn").DataBodyRange.Value2
Dim WordIdx As Long
Dim SearchCol As Long
Dim UpdateCol As Long
Dim rw As Long
Dim lr As ListRow
SearchCol = loMain.ListColumns("NameOfColumnToSearch").Index
UpdateCol = loMain.ListColumns("NameOfColumnToUpdate").Index
For Each lr In loMain.ListRows
With lr.Range
For WordIdx = 1 To UBound(wordsArray, 1)
If InStr(.Cells(1, SearchCol).Value2, wordsArray(WordIdx, 1)) > 0 Then
With .Cells(1, UpdateCol)
.Value2 = .Value2 & " " & FullWordsArray(WordIdx, 1)
End With
End If
Next
End With
Next
End Sub
After all of these years, I've seen several questions that asks how to populate an Array with a Recordset, but none that addresses how to write the output onto a worksheet all in one procedure. So, I decided to ask the Question in order to provide an answer that I've developed over time.
'Goes on Top
Option Explicit
Option Compare Text
Option Base 1
Public Sub Recordset_to_Array_to_Worksheet()
Dim MyArray() As Variant 'unbound Array with no definite dimensions'
Dim db as DAO.Database
Dim rst as DAO.Recordset
Dim strSQL as String, Fieldname as String
Dim i as Integer, j as Integer, colcnt as Integer, rowcnt as Integer
Dim wb as Workbook
Dim ws as Worksheet
Dim Dest as Range
'------------------------RECORDSET------------------------'
Set db = Opendatabase("URL link") 'or Set db = Currentdb()
strSQL = "SQL Statement Here"
Set rst = db.OpenRecordset(strsQL, dbOpenDynaset)
If rst.recordcount <> 0 then '///Do NOT Use "Do While Not rst.EOF" Can cause Problems///'
colcnt = rst.Fields.Count-1
rowcnt = rst.recordcount
Else
Exit Sub
End IF
'-----------------------------WRITE RECORDSET TO MYARRAY----------------------------'
ReDim MyArray (rowcnt, colcnt) 'Redimension MyArray parameters to fit the SQL returned'
rst.MoveFirst
'Populating Array with Headers from Recordset'
For j = 0 To colcnt
MyArray(0,j) = rst.Fields(j).name
Next
'Populating Array with Record Data
For i = 1 to rowcnt
For j = 0 to colcnt
MyArray(i,j) = rst(j)
Next J
rst.movenext
Next i
'---------------------------------WORKSHEET OUTPUT---------------------------------'
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Insert Worksheet Name")
Set Dest = ws.Range("A1") 'Destination Cell
Dest.Resize(UBound(MyArray, 1) + 1, UBound(MyArray, 2) + 1).value =
Application.Transpose(MyArray) 'Resize (secret sauce)
End Sub
I'm currently working with a workbook containing 34 different tabs.
I'm trying to extract Monthly Data from each of the tabs and Transpose it into daily figures for each specific city.
I have put all the dates within the year 2019 as columns in order to present it as daily figures. (See example in img below)
Each tab contains data for each specific city.
I always want to extract the data present on row 20 from column 4 to 15 in each tab for each specific city. ( see 2nd image below highlighted in yellow)
Public Sub CreateArray()
Dim myArrayOfMonths(11) As Double
Dim currentWorkbook As Workbook
Dim currentSheet As Worksheet
Dim otherSheet As Worksheet
Dim i As Integer
Dim r As Integer
Dim c As Integer
Dim j As Integer
Set currentWorkbook = ActiveWorkbook
Set otherSheet = currentWorkbook.Worksheets("Output")
i = 1
For Each currentSheet In currentWorkbook.Worksheets
r = 20
j = 0
For c = 4 To 15
myArrayOfMonths(j) = ActiveSheet.Cells(r, c)
j = j + 1
Next c
Debug.Print myArrayOfMonths(0)
i = i + 1
Next currentSheet
Set currentSheet = Nothing
Set currentWorkbook = Nothing
End Sub
In my code I'm trying to run through all of the tabs with a loop
and with a 2nd loop check the date (row 16, column 4 to 15) and extract it on my template (Similiar to a vlookup) Unfortunately, it never passes through the first tab as i=0 always for some reason.
Could you please advise?
Would you be able to do something like this?
Option Explicit
Public Sub PopulateOutput()
Dim outputSheet As Worksheet
Dim i As Integer
Set outputSheet = ActiveWorkbook.Worksheets("Output")
' starting at index 2 since output sheet looks like index 1
For i = 2 To ActiveWorkbook.Worksheets.Count
With ActiveWorkbook.Worksheets(i)
outputSheet.Range("B" & i & ":M" & i).Value = .Range("D20:O20").Value
End With
Next
End Sub
Does this suit your needs?
Public Sub CreateArray()
Dim myArrayOfMonths(11) As Double
Dim currentWorkbook As Workbook
Dim currentSheet As Worksheet
Dim otherSheet As Worksheet
Dim r As Integer
Dim c As Integer
Set currentWorkbook = ActiveWorkbook
Set otherSheet = currentWorkbook.Worksheets("Output")
For Each currentSheet In currentWorkbook.Worksheets
r = 20
For c = 4 To 15
myArrayOfMonths(c - 4) = myArrayOfMonths(c - 4) + currentSheet.Cells(r, c)
Next c
Next currentSheet
otherSheet.Range("B1:M1").Value = myArrayOfMonths
Set currentSheet = Nothing
Set currentWorkbook = Nothing
End Sub
Use currentSheet.Cells(r,c) instead of ActiveSheet
or use currentSheet.Activate and then myArrayOfMonths(j) = ActiveSheet.Cells(r, c), but try to avoid ActiveSheet.
I'm searching a range in my sheet for certain values when either of these values is found I want to add the value from column A of that row to an array, only adding values that are not already present in the array. Once the range has been searched, I want to print the arrays to specified cells in the worksheet in 2 different columns.
Here's my code so far:
Dim Ws As Worksheet
Set Ws = Sheets("Sheet1")
Dim Leave() As Variant, Join() As Variant
Dim LastCol As Integer, LastRow As Integer, i As Integer, Z As Integer
Dim J As Long, L As Long
With Sheets("Sheet1")
'Find Last Col
LastCol = Sheets("Sheet1").Cells(3, Columns.Count).End(xlToLeft).Column
'Find last Row
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
LastRow = LastRow - 1
'ReDim Leave(1 To (LastRow - 1), LastCol)
'ReDim Join(1 To (LastRow - 1), LastCol)
For i = 5 To LastCol
For Z = 4 To LastRow
If Sheets("Sheet1").Cells(Z, i).Value = "0" Then
Leave(L) = Ws.Cells(Z, 1).Value
ElseIf Sheets("Sheet1").Cells(Z, i).Value = "-2" Then
Join(J) = Ws.Cells(Z, 1).Value
End If
Next Z
Next i
'Print array
End With
Thanks for any pointers/help in advance!
I believe this procedure accomplishes what you are looking for. You will need to modify the range in which you are searching and the destination sheet information, but the meat of the procedure is here:
Sub abc_Dictionary()
Dim oWS As Worksheet
Dim RangeToSearch As Range
Dim myCell As Range
Dim UniqueDict As Object
Set oWS = Worksheets("Sheet1")
Set RangeToSearch = oWS.Range("B1:B26") 'You can set this dynamically however you wish
Set UniqueDict = CreateObject("Scripting.Dictionary")
'Now we search the range for the given values.
For Each myCell In RangeToSearch
If (myCell.Text = "0" Or myCell.Text = "-2") And Not UniqueDict.exists(oWS.Range("A" & myCell.Row).Text) Then
UniqueDict.Add oWS.Range("A" & myCell.Row).Text, oWS.Range("A" & myCell.Row).Text
End If
Next
'Now we have a dictionary object with the unique values of column a
'So we just iterate and dump into Sheet2
Dim d As Variant
Dim Val As Variant
Dim DestRow As Integer
DestRow = 1 'This is the first row of data we will use on Sheet 2
d = UniqueDict.Items
For Each Val In d
Worksheets("Sheet2").Range("A" & DestRow).Value = Val
DestRow = DestRow + 1
Next
Set UniqueDict = Nothing
Set RangeToSearch = Nothing
Set oWS = Nothing
End Sub
I'm trying to copy worksheets from a master workbook to a target workbook but the sheets that I copy are different depending on if the value in rngCurrent is present in the worksheet name. For some reason I keep getting a subscript out or range error on the last line. Can anyone help me understand what's going on?
Sub test2()
Dim wb As Workbook
Dim master As Workbook
Dim wbCurrent As Workbook
Dim wbAdjustments As Workbook
Dim wsName As Worksheet
Dim rngEntityList As Range
Dim rngCurrentEntity As Range
Dim rngCurrent As Range
Dim arrWorksheets As Variant
Dim i As Integer
Dim wsCount As Integer
Set master = ThisWorkbook
Set rngCurrentEntity = master.Sheets("File Info").Range("rng_Entity") 'named range of single entity
Set rngEntityList = master.Sheets("Global").Range("rng_EntityList") 'list or entities
Set rngCurrent = rngEntityList.Find(rngCurrentEntity.Value, LookIn:=xlValues) ' find single entity in the list
If rngCurrent.Offset(, 4).Value = "FRP" Then 'find if it's FRP
Set wb = Application.Workbooks("Foreign.xlsx")
Else
Set wb = Application.Workbooks("Domestic.xlsx")
End If
Dim ws() As String ' declare string array
ReDim ws(wb.Worksheets.Count) As String ' set size dynamically
Dim counter As Long ' running counter for ws array
counter = 1
For i = 1 To wb.Worksheets.Count
If InStr(1, wb.Worksheets(i).Name, rngCurrent.Value) <> 0 Then
ws(counter) = wb.Worksheets(i).Name
counter = counter + 1
End If
Next
ReDim Preserve ws(counter) As String ' Get rid of empty array entries
wb.Worksheets(ws).Copy After:=master.Worksheets(master.Worksheets.Count)
End Sub
EDIT
The reason I need to do it this way is because I don't want the external links to the source notebook.
Complete and tested example
Sub Tester()
Dim wb As Workbook, i As Long
Set wb = ThisWorkbook
Dim ws() As String ' declare string array
ReDim ws(1 To wb.Worksheets.Count) As String ' set size dynamically
Dim counter As Long ' running counter for ws array
counter = 0
For i = 1 To wb.Worksheets.Count
If InStr(1, wb.Worksheets(i).Name, "test") <> 0 Then
counter = counter + 1
ws(counter) = wb.Worksheets(i).Name
End If
Next
ReDim Preserve ws(1 To counter)
wb.Worksheets(ws).Copy 'just makes a copy in a new workbook
End Sub
do this:
ReDim ws(1 To wb.Worksheets.count) As String ' set size dynamically, start from 1
Dim counter As Long ' running counter for ws array
For i = 1 To wb.Worksheets.count
If InStr(1, wb.Worksheets(i).name, rngCurrent.Value) <> 0 Then
counter = counter + 1 '<--| update counter
ws(counter) = wb.Worksheets(i).name
End If
Next