VBA Question: How to make this happen...

zendog1960

Active Member
Joined
Sep 27, 2003
Messages
459
Office Version
  1. 2019
Platform
  1. Windows
In the first table below I have a list of clients. Their ID Numbers are in Column A, their names in Column B, Column C holds a picture name, Column D is a formula to create a complete path to the image, Column E has a hyperlink to that image. Columns G & H is a table of each client and their ID numbers for use with vlookups and such. Now after the first table below I will explain what I am wanting to do....


Excel 2007
ABCDEFGH
112001Corina Stadler12001 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 01.jpg12001 - 01.jpg0-
212001Corina Stadler12001 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 02.jpg12001 - 02.jpg1xx - NoPhotoAvailable
312001Corina Stadler12001 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 03.jpg12001 - 03.jpg12001Corina Stadler
412002Stephanie Taggart12002 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 01.jpg12002 - 01.jpg12002Stephanie Taggart
512002Stephanie Taggart12002 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 02.jpg12002 - 02.jpg12003Trae Fowler
612003Trae Fowler12003 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12003 - 01.jpg12003 - 01.jpg12004Heather Perkins
712004Heather Perkins12004 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12004 - 01.jpg12004 - 01.jpg12005Raylene Irwin
812005Raylene Irwin12005 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12005 - 01.jpg12005 - 01.jpg
Sheet1
Cell Formulas
RangeFormula
D1=IF(C1<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C1,"")
D2=IF(C2<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C2,"")
D3=IF(C3<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C3,"")
D4=IF(C4<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C4,"")
D5=IF(C5<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C5,"")
D6=IF(C6<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C6,"")
D7=IF(C7<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C7,"")
D8=IF(C8<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C8,"")


What I want to do is copy the image hyperlinks into the corresponding row for that client. As you can see, Corina has 3 different pictures, Stephanie has 2 and the rest have only 1. This is just a sample from over hundreds of clients. How can I do this via VBA. I am having a difficult time wrapping my head around this.

Any and all help would be greatly appreciated!


Cell Formulas
RangeFormula
G10
G21
G312001
G412002
G512003
G612004
G712005
H1-
H2xx - NoPhotoAvailable
H3Corina Stadler
H4Stephanie Taggart
H5Trae Fowler
H6Heather Perkins
H7Raylene Irwin
I312001 - 01.jpg
I412002 - 01.jpg
I512003 - 01.jpg
I612004 - 01.jpg
I712005 - 01.jpg
J312001 - 02.jpg
J412002 - 02.jpg
K312001 - 03.jpg
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
zendog1960,

I assume that your raw data is already grouped/sorted in column A.

In the first screenshot below, I assume that the text in the YELLOW cells is already present. If it is not, then I can adjust the macro so that the results will start in cell G1.

Sample raw data:


Excel 2007
ABCDEFGHIJK
112001Corina Stadler12001 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 01.jpg12001 - 01.jpg0-
212001Corina Stadler12001 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 02.jpg12001 - 02.jpg1xx - NoPhotoAvailable
312001Corina Stadler12001 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 03.jpg12001 - 03.jpg
412002Stephanie Taggart12002 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 01.jpg12002 - 01.jpg
512002Stephanie Taggart12002 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 02.jpg12002 - 02.jpg
612003Trae Fowler12003 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12003 - 01.jpg12003 - 01.jpg
712004Heather Perkins12004 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12004 - 01.jpg12004 - 01.jpg
812005Raylene Irwin12005 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12005 - 01.jpg12005 - 01.jpg
9
Sheet1


After the macro:


Excel 2007
ABCDEFGHIJK
112001Corina Stadler12001 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 01.jpg12001 - 01.jpg0-
212001Corina Stadler12001 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 02.jpg12001 - 02.jpg1xx - NoPhotoAvailable
312001Corina Stadler12001 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 03.jpg12001 - 03.jpg12001Corina Stadler12001 - 01.jpg12001 - 02.jpg12001 - 03.jpg
412002Stephanie Taggart12002 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 01.jpg12002 - 01.jpg12002Stephanie Taggart12002 - 01.jpg12002 - 02.jpg
512002Stephanie Taggart12002 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 02.jpg12002 - 02.jpg12003Trae Fowler12003 - 01.jpg
612003Trae Fowler12003 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12003 - 01.jpg12003 - 01.jpg12004Heather Perkins12004 - 01.jpg
712004Heather Perkins12004 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12004 - 01.jpg12004 - 01.jpg12005Raylene Irwin12005 - 01.jpg
812005Raylene Irwin12005 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12005 - 01.jpg12005 - 01.jpg
9
Sheet1


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code:
Option Explicit
Sub ReorgData()
' hiker95, 12/16/2013
' http://www.mrexcel.com/forum/excel-questions/745454-visual-basic-applications-question-how-make-happen.html
Dim lr As Long, r As Long, nr As Long, n As Long, rr As Long, nc As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
nr = 2
For r = 1 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  nr = nr + 1
  If n = 1 Then
    Range("G" & nr).Resize(, 2).Value = Range("A" & r).Resize(, 2).Value
    Range("E" & r).Copy Range("I" & nr)
  ElseIf n > 1 Then
    Range("G" & nr).Resize(, 2).Value = Range("A" & r).Resize(, 2).Value
    nc = 8
    For rr = r To r + n - 1
      nc = nc + 1
      Cells(rr, "E").Copy Cells(nr, nc)
    Next rr
  End If
  r = r + n - 1
Next r
End Sub


Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.
 
Last edited:
Upvote 0
hiker95, it did work on the sample data very nicely. as you mention though the first two rows of columns G and H you have in yellow are needed as there are some that actually have these. If you could adjust you code to allow for that, it would be greatly appreciated.

Having said that, I tried to follow what was going on in your code but frankly it is over my head. I know the iteration within an iteration can be very confusing thus why I am here. May you could briefly explain what is happening within your code. I know it would greatly help me understand it and hopefully will provide the knowledge to use it again in the future.

Thanks so much!
 
Upvote 0
zendog1960,

The new macro will adjust for any data (or no data) in column G.

Sample raw data:


Excel 2007
ABCDEFGHIJK
112001Corina Stadler12001 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 01.jpg12001 - 01.jpg
212001Corina Stadler12001 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 02.jpg12001 - 02.jpg
312001Corina Stadler12001 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 03.jpg12001 - 03.jpg
412002Stephanie Taggart12002 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 01.jpg12002 - 01.jpg
512002Stephanie Taggart12002 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 02.jpg12002 - 02.jpg
612003Trae Fowler12003 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12003 - 01.jpg12003 - 01.jpg
712004Heather Perkins12004 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12004 - 01.jpg12004 - 01.jpg
812005Raylene Irwin12005 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12005 - 01.jpg12005 - 01.jpg
9
Sheet1


After the new macro:


Excel 2007
ABCDEFGHIJK
112001Corina Stadler12001 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 01.jpg12001 - 01.jpg12001Corina Stadler12001 - 01.jpg12001 - 02.jpg12001 - 03.jpg
212001Corina Stadler12001 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 02.jpg12001 - 02.jpg12002Stephanie Taggart12002 - 01.jpg12002 - 02.jpg
312001Corina Stadler12001 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 03.jpg12001 - 03.jpg12003Trae Fowler12003 - 01.jpg
412002Stephanie Taggart12002 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 01.jpg12002 - 01.jpg12004Heather Perkins12004 - 01.jpg
512002Stephanie Taggart12002 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 02.jpg12002 - 02.jpg12005Raylene Irwin12005 - 01.jpg
612003Trae Fowler12003 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12003 - 01.jpg12003 - 01.jpg
712004Heather Perkins12004 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12004 - 01.jpg12004 - 01.jpg
812005Raylene Irwin12005 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12005 - 01.jpg12005 - 01.jpg
9
Sheet1


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Code:
Option Explicit
Sub ReorgDataV2()
' hiker95, 12/16/2013
' http://www.mrexcel.com/forum/excel-questions/745454-visual-basic-applications-question-how-make-happen.html
Dim lr As Long, nrg As Long, r As Long, nr As Long, n As Long, rr As Long, nc As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  nrg = Range("G" & Rows.Count).End(xlUp).Offset(1).Row
  If nrg = 2 And Range("G1") = "" Then nrg = 1
  If n = 1 Then
    Range("G" & nrg).Resize(, 2).Value = Range("A" & r).Resize(, 2).Value
    Range("E" & r).Copy Range("I" & nrg)
  ElseIf n > 1 Then
    Range("G" & nrg).Resize(, 2).Value = Range("A" & r).Resize(, 2).Value
    nc = 8
    For rr = r To r + n - 1
      nc = nc + 1
      Cells(rr, "E").Copy Cells(nrg, nc)
    Next rr
  End If
  r = r + n - 1
Next r
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataV2 macro.
 
Upvote 0
well something is amiss here. The first code you did populate some of the cells. The V2 sub doesn't put in any on my sheet. However when I got step by step through the code, it seems to be flowing through all the for and nexts but it doesn't post anything to the workbook. I took V2 sub out and pasted the old on back in and it still does what it did just fine but the new one doesn't...

Can you help out with this one?
 
Upvote 0
ok I just confirmed. Both V1 and V2 are creating data in Columns G and H. That is not necessary as in the actual sheet, this data is already created via a data link to another workbook. So Columns G & H do not need to be manipulated. The rest of the data that V1 and V2 does, is very much needed.

In the last post I found out that V2 was in fact creating data, but it was putting it at the bottom of the list way down there out of range. I think this was because it was creating columns G & H as well as the others... LOL

I hope this helps.
 
Upvote 0
zendog1960,

You have seen the posted screenshots where the new macro code works, my reply #5.

In order to continue I will need to see your actual workbook:

You can upload your workbook to Box Net,
sensitive data changed
mark the workbook for sharing
and provide us with a link to your workbook.


If you are not able to give us your actual workbook, per the above, then:

Click on the Reply to Thread button, and just put the word BUMP in the thread. Then, click on the Post Quick Reply button, and someone else will assist you.
 
Upvote 0
zendog1960,

Thanks for the new workbook.

Sample raw data (not all 132 rows are shown for brevity:


Excel 2007
ABCDE
112001Corina Stadler12001 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 01.jpg12001 - 01.jpg
212001Corina Stadler12001 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 02.jpg12001 - 02.jpg
312001Corina Stadler12001 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12001 - 03.jpg12001 - 03.jpg
412002Stephanie Taggart12002 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 01.jpg12002 - 01.jpg
512002Stephanie Taggart12002 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12002 - 02.jpg12002 - 02.jpg
612003Trae Fowler12003 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12003 - 01.jpg12003 - 01.jpg
712004Heather Perkins12004 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12004 - 01.jpg12004 - 01.jpg
812005Raylene Irwin12005 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12005 - 01.jpg12005 - 01.jpg
912007Chantell Heupel12007 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12007 - 01.jpg12007 - 01.jpg
1012007Chantell Heupel12007 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12007 - 02.jpg12007 - 02.jpg
1112007Chantell Heupel12007 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12007 - 03.jpg12007 - 03.jpg
1212008Mathea Aspelund12008 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12008 - 01.jpg12008 - 01.jpg
1312008Mathea Aspelund12008 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12008 - 02.jpg12008 - 02.jpg
1412008Mathea Aspelund12008 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12008 - 03.jpg12008 - 03.jpg
1512013Blaze Angeline12013 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12013 - 01.jpg12013 - 01.jpg
1612014Josy Rudnick12014 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12014 - 01.jpg12014 - 01.jpg
1712018Amber Downing12018 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12018 - 01.jpg12018 - 01.jpg
1812019William Baker12019 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12019 - 01.jpg12019 - 01.jpg
1912019William Baker12019 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12019 - 02.jpg12019 - 02.jpg
2012019William Baker12019 - 03.JPGe:\01 - Bullethead Tattoo\02 - Tattoos\12019 - 03.JPG12019 - 03.JPG
2112021Josh Rodriguez12021 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12021 - 01.jpg12021 - 01.jpg
2212021Josh Rodriguez12021 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12021 - 02.jpg12021 - 02.jpg
2312021Josh Rodriguez12021 - 03.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12021 - 03.jpg12021 - 03.jpg
2412021Josh Rodriguez12021 - 04.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12021 - 04.jpg12021 - 04.jpg
2512022Tonya Ivanoff12022 - 01.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12022 - 01.jpg12022 - 01.jpg
2612022Tonya Ivanoff12022 - 02.jpge:\01 - Bullethead Tattoo\02 - Tattoos\12022 - 02.jpg12022 - 02.jpg
Sheet1
Cell Formulas
RangeFormula
D1=IF(C1<>"","e:\01 - Bullethead Tattoo\02 - Tattoos\" & C1,"")


After the new macro (not all 72 rows are shown for brevity):


Excel 2007
GHIJKLMNO
112001Corina Stadler12001 - 01.jpg12001 - 02.jpg12001 - 03.jpg
212002Stephanie Taggart12002 - 01.jpg12002 - 02.jpg
312003Trae Fowler12003 - 01.jpg
412004Heather Perkins12004 - 01.jpg
512005Raylene Irwin12005 - 01.jpg
612007Chantell Heupel12007 - 01.jpg12007 - 02.jpg12007 - 03.jpg
712008Mathea Aspelund12008 - 01.jpg12008 - 02.jpg12008 - 03.jpg
812013Blaze Angeline12013 - 01.jpg
912014Josy Rudnick12014 - 01.jpg
1012018Amber Downing12018 - 01.jpg
1112019William Baker12019 - 01.jpg12019 - 02.jpg12019 - 03.JPG
1212021Josh Rodriguez12021 - 01.jpg12021 - 02.jpg12021 - 03.jpg12021 - 04.jpg
1312022Tonya Ivanoff12022 - 01.jpg12022 - 02.jpg12022 - 03.jpg12022 - 04.jpg
1412023Katie Lauderdale12023 - 01.jpg
1512024Marquie Casteel12024 - 01.jpg12024 - 02.jpg12024 - 03.jpg
1612025Amanda Maybee12025 - 01.jpg12025 - 02.jpg
1712026David Van Horn12026 - 01.jpg12026 - 02.jpg12026 - 03.jpg
1812027Becky Stinson12027 - 01.jpg
1912029Ian Nasayao12029 - 01.jpg
2012030Terri Tidmore12030 - 01.jpg12030 - 02.jpg
2112031Kristina Fritz12031 - 01.jpg12031 - 02.jpg12031 - 03.jpg
2212032Tyler Ferrell12032 - 01.jpg
2312033Andrew Reeves12033 - 01.jpg
2412034Jennifer Van Horn12034 - 01.jpg
2512035Sara Griffin12035 - 01.jpg12035 - 02.jpg12035 - 03.jpg12035 - 03a.jpg12035 - 03b.jpg12035 - 03c.jpg12035 - 03d.jpg
Sheet1


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Code:
Option Explicit
Sub ReorgDataV3()
' hiker95, 12/17/2013
' http://www.mrexcel.com/forum/excel-questions/745454-visual-basic-applications-question-how-make-happen.html
Dim lr As Long, nrg As Long, r As Long, nr As Long, n As Long, rr As Long, nc As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To lr
  n = Application.CountIf(Columns(1), Cells(r, 1).Value)
  nrg = Range("G" & Rows.Count).End(xlUp).Offset(1).Row
  If nrg = 2 And Range("G1") = "" Then nrg = 1
  If n = 1 Then
    Range("G" & nrg).Resize(, 2).Value = Range("A" & r).Resize(, 2).Value
    Range("E" & r).Copy Range("I" & nrg)
  ElseIf n > 1 Then
    Range("G" & nrg).Resize(, 2).Value = Range("A" & r).Resize(, 2).Value
    nc = 8
    For rr = r To r + n - 1
      nc = nc + 1
      Cells(rr, "E").Copy Cells(nrg, nc)
    Next rr
  End If
  r = r + n - 1
Next r
Columns.AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgDataV3 macro (this macro has one addition at the end Columns.AutoFit)
 
Last edited:
Upvote 0

Forum statistics

Threads
1,224,812
Messages
6,181,096
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top